根据数据A列去重，合并B列数据到同一个单元格

1074387977

老师，我想把A列数据去重，然后实现B列数据源的单号，引入到同一个单元格，麻烦老师帮忙解答下，谢谢

ykcbf1100

附件供参考。。。

醉眼看尘世

1. Sub test()
   
2. Dim Dic As Object, i&, Arr
   
3. Set Dic = CreateObject("scripting.dictionary")
   
4. Arr = Sheet1.[a1].CurrentRegion
   
5. For i = 2 To UBound(Arr, 1)
   
6.     If Dic.exists(Arr(i, 1)) Then
   
7.         Dic(Arr(i, 1)) = Dic(Arr(i, 1)) & "、" & Arr(i, 2)
   
8.     Else
   
9.         Dic(Arr(i, 1)) = Arr(i, 2)
   
10.     End If
    
11. Next i
    
12. With Sheet2
    
13.     .Range("A:B").ClearContents
    
14.     .[a1:b1] = Arr
    
15.     .[a2].Resize(Dic.Count, 2) = Application.WorksheetFunction.Transpose(Array(Dic.keys, Dic.items))
    
16. End With
    
17. End Sub
    

复制代码

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.26
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("数据")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 2)
   
6.     End With
   
7.     ReDim brr(1 To r, 1 To 2)
   
8.     For i = 2 To UBound(arr)
   
9.         s = arr(i, 1)
   
10.         If Not d.exists(s) Then
    
11.             m = m + 1
    
12.             d(s) = m
    
13.             brr(m, 1) = s
    
14.             brr(m, 2) = arr(i, 2)
    
15.         Else
    
16.             r = d(s)
    
17.             brr(r, 2) = brr(r, 2) & "，" & arr(i, 2)
    
18.         End If
    
19.     Next
    
20.     With Sheets("结果")
    
21.         .UsedRange.Offset(1).ClearContents
    
22.         .[a2].Resize(m, 2) = brr
    
23.     End With
    
24.     MsgBox "OK！"
    
25. End Sub
    

复制代码

1074387977

ykcbf1100 发表于 2024-8-26 18:37
附件供参考。。。

谢谢老师，可以了，非常感谢，去年也是您帮忙解答的

smuuwl

字典经典用法

ykcbf1100

1074387977 发表于 2024-8-26 18:39
谢谢老师，可以了，非常感谢，去年也是您帮忙解答的

能帮到你就好。。。

chxw68

参与一下。

无关岁月

这么规律，字典都不用

去重合并.7z (11.28 KB, 下载次数: 7)

2024-8-26 19:33 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, r&, dic As Object, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Worksheets(1).[A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        dic(ar(i, 1)) = dic(ar(i, 1)) & "," & ar(i, 2)
    Next i
     
    ReDim ar(dic.Count, 1)
    ar(0, 0) = "购方名称": ar(0, 1) = "订单号"
    For Each vKey In dic.keys
        r = r + 1
        ar(r, 0) = vKey
        ar(r, 1) = Mid(dic(vKey), 2)
    Next
   
    [E1].Resize(UBound(ar) + 1, 2) = ar
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub