vba多次循环并集问题

天边六朵云

利用vba字典或其它手段对数据进行并集分组，如图0组有数字1,2；2组有数字3,4,5；3组有数字2,3。只要任一祖内数字与其他组某个数字相同，则归于同一组(组号可取最小值)。结果即为组：0 元素：1,2,3,4,5

示例

ww87725244

我似乎理解错了

天边六朵云

ww87725244 发表于 2018-6-5 19:15
我似乎理解错了

哦，哪里有疑问？

一把小刀闯天下

Option Explicit

Sub test()
  Dim i, j, k, first As Boolean, dic, t, arr, n
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a2:c" & Cells(Rows.Count, "b").End(xlUp).Row)
  ReDim brr(1 To UBound(arr, 1), 1 To 2)
  For i = 1 To UBound(arr, 1): arr(i, 3) = vbNullString: Next
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 3)) = 0 Then
      arr(i, 2) = Replace(arr(i, 2), "，", ",")
      first = True: dic.RemoveAll
      For j = 1 To UBound(arr, 1)
        If Len(arr(j, 3)) = 0 Then
          arr(j, 2) = Replace(arr(j, 2), "，", ",")
          If first Then
            n = n + 1: first = False
            brr(n, 1) = arr(i, 1): brr(n, 2) = arr(i, 2): arr(i, 3) = n
            If InStr(arr(i, 2), ",") Then
              t = Split(arr(i, 2), ",")
              For k = 0 To UBound(t): dic(t(k)) = vbNullString: Next
            Else
              dic(arr(i, 2)) = vbNullString
            End If
          Else
            If InStr(arr(j, 2), ",") Then
              t = Split(arr(j, 2), ",")
              For k = 0 To UBound(t)
                If dic.exists(t(k)) Then Exit For
              Next
              If k < UBound(t) + 1 Then
                For k = 0 To UBound(t): dic(t(k)) = vbNullString: Next
              End If
            Else
              If dic.exists(arr(j, 2)) Then dic(arr(j, 2)) = vbNullString
            End If
          End If
        End If
      Next
      For j = 1 To UBound(arr, 1)
        If InStr(arr(j, 2), ",") Then
          t = Split(arr(j, 2), ",")
          For k = 0 To UBound(t)
            If dic.exists(t(k)) Then Exit For
          Next
          If k < UBound(t) + 1 Then brr(n, 2) = brr(n, 2) & "," & arr(j, 2): arr(j, 3) = n
        Else
          If dic.exists(arr(j, 2)) Then brr(n, 2) = brr(n, 2) & "," & arr(j, 2): arr(j, 3) = n
        End If
      Next
    End If
  Next
  For i = 1 To n
    If InStr(brr(i, 2), ",") Then
      dic.RemoveAll: t = Split(brr(i, 2), ",")
      For j = 0 To UBound(t): dic(t(j)) = vbNullString: Next
      brr(i, 2) = Join(dic.keys, ",")
    End If
  Next
  With [e3]
    .Resize(Rows.Count - 2, 2).ClearContents
    .Resize(n, 2) = brr
  End With
End Sub