[已解决]怎样有条件地合并单元格内容，

KDZ

请问各位大侠：如何用VBA实现单元格内容合并？条件见附件，谢谢！

最佳答案

月排行榜 / 总排行榜

这儿有肥猫

2014-10-20 12:50

1. Sub a()
   
2. Dim i&,  arr,   dic As Object
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = [a2:c7]
   
5. For i = 1 To UBound(arr)
   
6.     dic(arr(i, 1) & "|" & arr(i, 2)) = dic(arr(i, 1) & "|" & arr(i, 2)) & " " & arr(i, 3)
   
7. Next
   
8. 
   
9. [h2].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
   
10. [i2].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    
11. [j2].Resize(dic.Count, 1) = Application.Transpose(dic.items)
    
12. 
    
13. Range("h:h").Replace "|*", ""
    
14. Range("I:I").Replace "*|", ""
    
15. 
    
16. End Sub

复制代码

跳转到最佳答案楼层

这儿有肥猫

供参考

这儿有肥猫

1. Sub a()
   
2. Dim i&,  arr,   dic As Object
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = [a2:c7]
   
5. For i = 1 To UBound(arr)
   
6.     dic(arr(i, 1) & "|" & arr(i, 2)) = dic(arr(i, 1) & "|" & arr(i, 2)) & " " & arr(i, 3)
   
7. Next
   
8. 
   
9. [h2].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
   
10. [i2].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    
11. [j2].Resize(dic.Count, 1) = Application.Transpose(dic.items)
    
12. 
    
13. Range("h:h").Replace "|*", ""
    
14. Range("I:I").Replace "*|", ""
    
15. 
    
16. End Sub

复制代码

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a2").CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6. For i = 2 To UBound(arr)
   
7.     If Not d.exists(arr(i, 1)) Then
   
8.         s = s + 1
   
9.         d(arr(i, 1)) = s
   
10.         For j = 1 To UBound(arr, 2)
    
11.             brr(s, j) = arr(i, j)
    
12.         Next
    
13.     Else
    
14.         brr(d(arr(i, 1)), 3) = brr(d(arr(i, 1)), 3) & " " & arr(i, 3)
    
15.     End If
    
16. Next
    
17. [e2].Resize(s, UBound(brr, 2)) = brr
    
18. End Sub

复制代码

KDZ

谢谢各位大师！