如何利用VBA将俩列一对多，多对一数据串联起来进行分组

biyupeng

如何利用VBA将俩列一对多，多对一数据串联起来进行分组，
例：A→B,B→C,B→C,B→D,A→C,C→A,C→B等，这些统一归为1组，按顺序排序，不同组区分开来。入下图所示：

zopey

Sub 按钮1_Click()
Range("c2:c65536").ClearContents
Dim d As Object, d2 As Object, ar, k
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
ar = Range("a2:c" & [a65536].End(3).Row).Value

For i = 1 To UBound(ar)
    If d.exists(ar(i, 1)) Then
        If d.exists(ar(i, 2)) Then
           If d(ar(i, 1)) = d(ar(i, 2)) Then
              ar(i, 3) = d(ar(i, 1))
           ElseIf d(ar(i, 1)) < d(ar(i, 2)) Then
              ar(i, 3) = d(ar(i, 1))
              d2(d(ar(i, 2))) = d(ar(i, 1))
           Else
              ar(i, 3) = d(ar(i, 2))
              d2(d(ar(i, 1))) = d(ar(i, 2))
           End If
        Else
           ar(i, 3) = d(ar(i, 1))
           d(ar(i, 2)) = ar(i, 3)
        End If
    ElseIf d.exists(ar(i, 2)) Then
        ar(i, 3) = d(ar(i, 2))
        d(ar(i, 1)) = ar(i, 3)
    Else
        k = k + 1
        ar(i, 3) = k
        d(ar(i, 1)) = ar(i, 3)
        d(ar(i, 2)) = ar(i, 3)
    End If
Next

For i = 1 To UBound(ar)
    If d2.exists(ar(i, 3)) Then ar(i, 3) = d2(ar(i, 3))
Next

[a2].Resize(UBound(ar), 3) = ar
End Sub

一把小刀闯天下

'分组、输出连接。未作去重，自己排一下序就能删除

Option Explicit

Sub test()
  Dim arr, dic(1), i, j, k, kk, n, key, m, t
  Columns("d").Resize(, 30).ClearContents
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  arr = Range("a2:b" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
  ReDim brr(1 To UBound(arr, 1) - 1, 1 To 1)
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      For kk = 0 To 1
        If dic(kk).exists(arr(j, 1)) Then
          dic(kk)(arr(j, kk + 1)) = dic(0)(arr(j, 1)) & "|" & arr(j, IIf(kk = 0, 2, 1))
        Else
          dic(kk)(arr(j, kk + 1)) = arr(j, IIf(kk = 0, 2, 1))
        End If
      Next
      If Not dic(0).exists(arr(j + 1, 2)) And Not dic(1).exists(arr(j + 1, 1)) _
        Or Len(arr(i, 1)) = 0 Then
        n = n + 1
        For k = i To j: brr(k, 1) = n: Next
        For kk = 0 To 1
          For Each key In dic(kk).keys
            If InStr(dic(kk)(key), "|") Then
              t = Split(dic(kk)(key), "|")
              For k = 0 To UBound(t)
                m = m + 1: Cells(m, n + 6) = key & "-" & t(k)
              Next
            Else
              m = m + 1: Cells(m, n + 6) = key & "-" & dic(kk)(key)
            End If
        Next key, kk
        i = j: m = 0: dic(0).RemoveAll: dic(1).RemoveAll: Exit For
      End If
  Next j, i
  [d2].Resize(UBound(brr, 1)) = brr
End Sub

Chip_Kenny

1. Sub zz()
   
2. Dim d As Object, n
   
3. Set d = CreateObject("scripting.dictionary")
   
4. ar = Range("a2:c" & [a65536].End(3).Row).Value
   
5. d(ar(1, 1)) = 1: d(ar(1, 2)) = 1: ar(1, 3) = 1
   
6. For i = 2 To UBound(ar)
   
7.     If d.exists(ar(i, 1)) Or d.exists(ar(i, 2)) Then
   
8.         ar(i, 3) = Application.Max(d(ar(i, 1)), d(ar(i, 2)))
   
9.     Else
   
10.         ar(i, 3) = ar(i - 1, 3) + 1
    
11.     End If
    
12.     For j = 1 To UBound(ar, 2) - 1
    
13.         d(ar(i, j)) = ar(i, 3)
    
14.     Next
    
15. Next
    
16. [a2].Resize(UBound(ar), 3) = ar
    
17. End Sub

复制代码

biyupeng

Chip_Kenny 发表于 2018-6-5 15:59

这个结果应该是3，应该从2往下排序，不是从1排序file:///C:/Users/Administrator/Desktop/Catch93EB.jpg

天边六朵云

Chip_Kenny 发表于 2018-6-5 15:59

这个代码未考虑排序及并集问题吧，如图片：

Chip_Kenny

biyupeng 发表于 2018-6-5 17:51
这个结果应该是3，应该从2往下排序，不是从1排序

1. Sub zz()
   
2. Dim d As Object, n
   
3. Set d = CreateObject("scripting.dictionary")
   
4. ar = Range("a2:c" & [a65536].End(3).Row).Value
   
5. d(ar(1, 1)) = 1: d(ar(1, 2)) = 1: ar(1, 3) = 1
   
6. For i = 2 To UBound(ar)
   
7.     If d.exists(ar(i, 1)) Or d.exists(ar(i, 2)) Then
   
8.         ar(i, 3) = Application.Max(d(ar(i, 1)), d(ar(i, 2)))
   
9.     Else
   
10.         ar(i, 3) = Application.Max(d.items) + 1
    
11.     End If
    
12.     For j = 1 To UBound(ar, 2) - 1
    
13.         d(ar(i, j)) = ar(i, 3)
    
14.     Next
    
15. Next
    
16. [a2].Resize(UBound(ar), 3) = ar
    
17. End Sub

复制代码

biyupeng

Chip_Kenny 发表于 2018-6-5 20:14

出现5楼的问题了，第一列和第二列没有关联的话，第三列和第一列有关联，就不会分到一组。

Chip_Kenny

biyupeng 发表于 2018-6-6 08:47
出现5楼的问题了，第一列和第二列没有关联的话，第三列和第一列有关联，就不会分到一组。

Sub zz()
Dim ar, br, b(), n, m, k, t As Boolean
Dim d As Object, dd As Object
Set d = CreateObject("scripting.dictionary")
Set dd = CreateObject("scripting.dictionary")
br = Range("a2:c" & [a65536].End(3).Row).Value
ar = br
ReDim b(UBound(ar))
For i = 1 To UBound(ar) - 1
    m = ar(i, 1)
    For j = i + 1 To UBound(ar)
        If m > ar(j, 1) Then m = ar(j, 1): k = j: t = True
    Next
    If t Then
        t = False
        For j = 1 To UBound(ar, 2)
            b(j) = ar(i, j): ar(i, j) = ar(k, j): ar(k, j) = b(j)
        Next
    End If
Next
d(ar(1, 1)) = 1: ar(1, 3) = 1
dd(ar(1, 1) & ar(1, 2)) = ar(1, 3)
For i = 2 To UBound(ar)
    If d.exists(ar(i, 1)) Or d.exists(ar(i, 2)) Then
        ar(i, 3) = Application.Max(d(ar(i, 1)), d(ar(i, 2)))
    Else
        ar(i, 3) = Application.Max(d.items) + 1
    End If
    For j = 1 To UBound(ar, 2) - 1
        d(ar(i, j)) = ar(i, 3)
    Next
    dd(ar(i, 1) & ar(i, 2)) = ar(i, 3)
Next
For i = 1 To UBound(br)
    br(i, 3) = dd(br(i, 1) & br(i, 2))
Next
[a2].Resize(UBound(ar), 3) = br
Set d = Nothing: Set dd = Nothing
End Sub

biyupeng

Chip_Kenny 发表于 2018-6-6 09:50
Sub zz()
Dim ar, br, b(), n, m, k, t As Boolean
Dim d As Object, dd As Object

两个代码都是每次循环到i=78313就会报错，类型不匹配

Chip_Kenny

1. Sub zz()
   
2. Dim ar, br, b(), n, m, k, t As Boolean
   
3. Dim d As Object, dd As Object, [color=Red]accum&, i&, j&[/color]
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set dd = CreateObject("scripting.dictionary")
   
6. br = Range("a2:c" & [a65536].End(3).Row).Value
   
7. ar = br
   
8. ReDim b(UBound(ar))
   
9. For i = 1 To UBound(ar) - 1
   
10.     m = ar(i, 1)
    
11.     For j = i + 1 To UBound(ar)
    
12.         If m > ar(j, 1) Then m = ar(j, 1): k = j: t = True
    
13.     Next
    
14.     If t Then
    
15.         t = False
    
16.         For j = 1 To UBound(ar, 2)
    
17.             b(j) = ar(i, j): ar(i, j) = ar(k, j): ar(k, j) = b(j)
    
18.         Next
    
19.     End If
    
20. Next
    
21. [color=Red]accum = 1[/color]
    
22. d(ar(1, 1)) = 1: ar(1, 3) = 1
    
23. dd(ar(1, 1) & ar(1, 2)) = ar(1, 3)
    
24. For i = 2 To UBound(ar)
    
25.     If d.exists(ar(i, 1)) Or d.exists(ar(i, 2)) Then
    
26.         ar(i, 3) = Application.Max(d(ar(i, 1)), d(ar(i, 2)))
    
27.     Else
    
28.         [color=Red]ar(i, 3) = accum + 1: accum = ar(i, 3)[/color]
    
29.     End If
    
30.     For j = 1 To UBound(ar, 2) - 1
    
31.         d(ar(i, j)) = ar(i, 3)
    
32.     Next
    
33.     dd(ar(i, 1) & ar(i, 2)) = ar(i, 3)
    
34. Next
    
35. For i = 1 To UBound(br)
    
36.     br(i, 3) = dd(br(i, 1) & br(i, 2))
    
37. Next
    
38. [a2].Resize(UBound(ar), 3) = br
    
39. Set d = Nothing: Set dd = Nothing
    
40. End Sub

复制代码