求助大侠，不知如何说，看主贴

yuuk78

如附件所示，数据AB列，B列对应A列数据汇聚于一个单元格，各个数据间带","英文逗号。E列为我想要的结果，E列结果可能多于20个，只要任意20个。
请大侠帮帮忙，写个vba，谢谢。

测量点号	逻辑地址		逻辑地址	测量点号：重复保留一个，多于20个只保留任意20个。
10	1101000498FE		1101000498FE	10,11,13,14,15,16,17,18,19,2,20,21,3,4,5,6,7,8
11	1101000498FE		1101001936E2	10,13,14,16,21,22,23,24,25,26,28,3,32,33,34,4,5,6,7,8,9
13	1101000498FE
14	1101000498FE
15	1101000498FE
16	1101000498FE
17	1101000498FE
18	1101000498FE
19	1101000498FE
2	1101000498FE
20	1101000498FE
21	1101000498FE
3	1101000498FE
4	1101000498FE
5	1101000498FE
6	1101000498FE
7	1101000498FE
8	1101000498FE
10	1101001936E2
13	1101001936E2
14	1101001936E2
16	1101001936E2
21	1101001936E2
22	1101001936E2
23	1101001936E2
24	1101001936E2
25	1101001936E2
26	1101001936E2
28	1101001936E2
3	1101001936E2
32	1101001936E2
33	1101001936E2
34	1101001936E2
4	1101001936E2
5	1101001936E2
6	1101001936E2
7	1101001936E2
8	1101001936E2
9	1101001936E2	重复保留一个
9	1101001936E2

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set dd = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     arr = [a1].CurrentRegion
   
6.     For j = 2 To UBound(arr)
   
7.         d(arr(j, 2)) = d(arr(j, 2)) & "," & arr(j, 1)
   
8.     Next j
   
9.     For j = 0 To d.Count - 1
   
10.         dd.RemoveAll
    
11.         arr = Split(d.items()(j), ",")
    
12.         For i = 1 To UBound(arr)
    
13.             If dd.Count = 20 Then Exit For
    
14.             dd(arr(i)) = ""
    
15.         Next i
    
16. 
    
17.         Cells(j + 2, 4) = d.keys()(j)
    
18.         Cells(j + 2, 5) = Join(dd.keys, ",")
    
19. 
    
20.     Next j
    
21.     Application.ScreenUpdating = True
    
22. End Sub

复制代码

liulang0808

附件内容供参考。。。。。。

不知道为什么

也来凑个热闹

1. Sub test1()
   
2.     Dim Dic, Arr, Brr(), x%, i&, m$, s$
   
3.     Set Dic = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Arr = [a1].CurrentRegion
   
6.     ReDim Brr(1 To UBound(Arr), 1 To 2)
   
7.     For i = 2 To UBound(Arr)
   
8.         If Not Dic.exists(Arr(i, 2)) Then
   
9.             Set Dic(Arr(i, 2)) = CreateObject("scripting.dictionary")
   
10.         End If
    
11.         Dic(Arr(i, 2))(Arr(i, 1)) = Dic(Arr(i, 2))(Arr(i, 1)) + 1
    
12.     Next i
    
13.     For Each k In Dic.keys
    
14.         x = x + 1
    
15.         Brr(x, 1) = k
    
16.         m = Join(Dic(k).keys, ",")
    
17.         If Dic(k).Count <= 20 Then
    
18.             Brr(x, 2) = m
    
19.         Else
    
20.             For i = 0 To 19
    
21.                 s = s & "," & Split(m, ",")(i)
    
22.             Next i
    
23.             Brr(x, 2) = Right(s, Len(s) - 1)
    
24.             s = ""
    
25.         End If
    
26.     Next
    
27.     With [d2:e1000]
    
28.         .ClearContents
    
29.         .Resize(x, 2) = Brr
    
30.     End With
    
31.     Set Dic = Nothing
    
32.     Application.ScreenUpdating = True
    
33. End Sub
    

复制代码

不知道为什么

附件供参考