[已解决]求助！用VBA方法 合并A列中的相同单元格 同时合并B列中相应单元格内容，并用逗号隔开

mdhsjtu

工作急需，求那位大神帮帮忙。具体是这样的：数据一共有2列，20341行，要求合并A列中相同的单元格（相同的只要一个），并依据A列中相同的单元格，把B列对应的单元格内容合并，并且用逗号隔开，最好能把合并后B列中重复出现的内容（两逗号之间的）删除。。。
A 列   B列      
数学   A,B
语文   B,E
数学   B,C
英语   D
语文   D,E
数学   C
...

合并后变成：
A列    B列
数学  A,B,C
语文  B,D,E
英语  D
...

最佳答案

月排行榜 / 总排行榜

易安1

2014-7-23 12:50

1. Sub test()
   
2. Application.ScreenUpdating = False
   
3. n = 1
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = [a1].CurrentRegion
   
6. For i = 1 To UBound(arr)
   
7.     d(arr(i, 1)) = d(arr(i, 1)) & arr(i, 2) & ","
   
8. Next
   
9. [e1].Resize(d.Count) = Application.Transpose(d.keys)
   
10. cnt = d.Count
    
11. k = d.items
    
12. d.RemoveAll
    
13. For j = 0 To cnt
    
14. On Error Resume Next
    
15. 
    
16.     brr = Split(k(j), ",")
    
17.     For m = 0 To UBound(brr)
    
18.         d(brr(m)) = ""
    
19.     Next
    
20.     Cells(n, "f") = Join(d.keys, ",")
    
21.     Cells(n, "F") = Left(Cells(n, "f"), Len(Cells(n, "f")) - 1)
    
22.        n = n + 1
    
23.     d.RemoveAll
    
24. Next
    
25. Cells(Rows.Count, "F").End(3).Delete
    
26. Application.ScreenUpdating = False
    
27. End Sub
    

复制代码

跳转到最佳答案楼层

mdhsjtu

Sub test()
Dim arr, i%
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
arr = Range("a2:b13")
For i = 1 To UBound(arr)
    If Not d.Exists(arr(i, 1)) Then
        d(arr(i, 1)) = arr(i, 2)
    Else
        d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)
    End If
Next
Range("d2:e65536").ClearContents
[d2].Resize(d.Count, 1) = Application.Transpose(d.Keys)
[e2].Resize(d.Count, 1) = Application.Transpose(d.Items)
Set d = Nothing
End Sub

用了下 枯禅 大神回复相似主题的代码，但就是提示有buge，在 倒数第三行：[e2].Resize(d.Count, 1) = Application.Transpose(d.Items)
不知道是怎么修改，那位能帮忙修改下这段代码么？我的数据有2万多行

易安1

1. Sub test()
   
2. Application.ScreenUpdating = False
   
3. n = 1
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = [a1].CurrentRegion
   
6. For i = 1 To UBound(arr)
   
7.     d(arr(i, 1)) = d(arr(i, 1)) & arr(i, 2) & ","
   
8. Next
   
9. [e1].Resize(d.Count) = Application.Transpose(d.keys)
   
10. cnt = d.Count
    
11. k = d.items
    
12. d.RemoveAll
    
13. For j = 0 To cnt
    
14. On Error Resume Next
    
15. 
    
16.     brr = Split(k(j), ",")
    
17.     For m = 0 To UBound(brr)
    
18.         d(brr(m)) = ""
    
19.     Next
    
20.     Cells(n, "f") = Join(d.keys, ",")
    
21.     Cells(n, "F") = Left(Cells(n, "f"), Len(Cells(n, "f")) - 1)
    
22.        n = n + 1
    
23.     d.RemoveAll
    
24. Next
    
25. Cells(Rows.Count, "F").End(3).Delete
    
26. Application.ScreenUpdating = False
    
27. End Sub
    

复制代码

mdhsjtu

易安1 发表于 2014-7-23 12:50

非常感谢，但是我想跟进一步的处理下，大神可否再帮我一下？哈哈
接上次处理结果：
A列    B列
数学  A,B,C
语文  B,D,E
英语  D
...
最后变成：
A列       B列   C列   D列   E列   F列  ......
             A       B       C       D      E    ......
数学      √      √      √
语文               √               √      √
英语                                 √
...
这个如何处理呢？现在已经有了表头，就是A列的所有项目都已经有了（1200多行），然后第一行的所有项目A，B，C，D，E，F，G......共23个也都有了，就差往中间打对号了。或者这样说，按照上次的处理结果，往里面打勾，怎么处理啊大神？

易安1

mdhsjtu 发表于 2014-7-23 13:44
非常感谢，但是我想跟进一步的处理下，大神可否再帮我一下？哈哈
接上次处理结果：
A列    B列

编程这样 代码又要增加很多额

mdhsjtu

易安1 发表于 2014-7-23 13:57
编程这样 代码又要增加很多额

有不需要VBA的办法没？我想不出来。。或者就再麻烦您改改代码吧~~{:3112:}