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

一把小刀闯天下

'不输出连接一个字典就可以了，也可以不用字典但效率会差点

Option Explicit

Sub test()
  Dim i, j, arr, n, dic, first As Boolean
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a2:c" & Cells(Rows.Count, "a").End(xlUp).Row)
  For i = 2 To UBound(arr, 1): arr(i, 3) = vbNullString: Next
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 3)) = 0 Then
      first = True: dic.RemoveAll
      For j = 1 To UBound(arr, 1)
        If Len(arr(j, 3)) = 0 Then
          If first Then
            n = n + 1: first = False: arr(i, 3) = n
            dic(arr(i, 1)) = vbNullString: dic(arr(i, 2)) = vbNullString
          Else
            If dic.exists(arr(j, 1)) Or dic.exists(arr(j, 2)) Then
              arr(j, 3) = n
              dic(arr(j, 1)) = vbNullString: dic(arr(j, 2)) = vbNullString
            End If
          End If
        End If
      Next
    End If
  Next
  [a2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

biyupeng

Chip_Kenny 发表于 2018-6-6 11:33

biyupeng

一把小刀闯天下 发表于 2018-6-6 14:15
'不输出连接一个字典就可以了，也可以不用字典但效率会差点

Option Explicit

这么多IF，处理大批量的数据时候，就会卡住。

一把小刀闯天下

biyupeng 发表于 2018-6-6 14:53
这么多IF，处理大批量的数据时候，就会卡住。

因为是无序的那就得2个循环，if越多速度会越快。如果组非常多可以不用字典，不停的removeall时间开销挺大。

如果A、B列有序一个循环就能搞定，就像2楼的代码。

2000条无序数据应该没有压力（4*10^6循环），5000条以上估计得假死机（2.5*10^7循环）

一把小刀闯天下

biyupeng 发表于 2018-6-6 14:53
这么多IF，处理大批量的数据时候，就会卡住。

'如果组非常多就不用字典，否则速度会更慢。不假死可以在2个循环中个加入一个doevents，但速度会慢很多，好处就是你点一下它不假死机，最后弹出窗口就算结束了。
'组不多就不要修改代码，仅在相应的位置加入2个doevents就可以了。

Option Explicit

Sub test()
  Dim i, j, arr, n, dic, first As Boolean, t As String
  arr = Range("a2:c" & Cells(Rows.Count, "a").End(xlUp).Row)
  For i = 2 To UBound(arr, 1): arr(i, 3) = vbNullString: Next
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 3)) = 0 Then
      first = True: t = vbNullString
      For j = 1 To UBound(arr, 1)
        If Len(arr(j, 3)) = 0 Then
          If first Then
            n = n + 1: first = False: arr(i, 3) = n
            t = "|" & arr(i, 1) & "|" & arr(i, 2) & "|"
          Else
            If InStr(t, arr(j, 1)) > 0 Or InStr(t, arr(j, 2)) > 0 Then
              arr(j, 3) = n
              t = t & "|" & arr(j, 1) & "|" & arr(j, 2) & "|"
            End If
          End If
        End If
        DoEvents '<--
      Next
    End If
    DoEvents '<--
  Next
  [a2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
  MsgBox "ok!"
End Sub

biyupeng

一把小刀闯天下 发表于 2018-6-6 15:49
'如果组非常多就不用字典，否则速度会更慢。不假死可以在2个循环中个加入一个doevents，但速度会慢很多， ...

一般要处理50W行的数据，大概16W组的数据。

一把小刀闯天下

biyupeng 发表于 2018-6-6 16:05
一般要处理50W行的数据，大概16W组的数据。

用楼上的代码，不然removeall30万次停可怕

因为是无序的，50万行2500亿循环，，，。有序20s能搞定

zopey

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

d(ar(1, 1)) = 1: d(ar(1, 2)) = 1
ar(1, 3) = 1: k = 1
For i = 2 To UBound(ar)
    If d.exists(ar(i, 1)) Then
        ar(i, 3) = d(ar(i, 1))
        d(ar(i, 2)) = ar(i, 3)
    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

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

两列数据.zip (13.46 KB, 下载次数: 1)

2018-6-6 17:29 上传

点击文件名下载附件

biyupeng

zopey 发表于 2018-6-6 17:30
Sub 按钮1_Click()
Dim d As Object, n
Set d = CreateObject("scripting.dictionary")

以A列排序和B列排序，得到不同的结果，这种情况可以避免吗？

zopey

biyupeng 发表于 2018-6-7 08:49
以A列排序和B列排序，得到不同的结果，这种情况可以避免吗？

最好有实际数据及模拟结果，方便调试验证。

修改过的代码，用了2个字典对象

两列数据2.zip (14.35 KB, 下载次数: 0)

2018-6-7 08:57 上传

点击文件名下载附件