[已解决]如何对满足条件的记录，对某项进行去重后合并字符串

dubei

问题如图所示，请问其VBA该怎么写？谢谢！

问题附件见： HelpMe.rar (2.39 KB, 下载次数: 6)

2015-11-4 06:56 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2015-11-5 11:12

1. Sub 去重合并()
   
2.     arr = Range("a1:d" & [b65536].End(3).Row)
   
3.     ReDim brr(1 To UBound(arr), 1 To 3)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr)
   
6.         x = arr(i, 2) & arr(i, 3): y = "," & arr(i, 4) & ","
   
7.         If Not d.exists(x) Then
   
8.             n = n + 1: d(x) = n
   
9.             brr(n, 1) = arr(i, 2)
   
10.             brr(n, 2) = arr(i, 3)
    
11.         End If
    
12.         p = d(x)
    
13.         If Len(arr(i, 4)) > 0 Then
    
14.             If InStr(brr(p, 3), y) = 0 Then brr(p, 3) = brr(p, 3) & y
    
15.         End If
    
16.     Next
    
17.     For i = 1 To n
    
18.         brr(i, 3) = Replace(Mid(brr(i, 3), 2, Len(brr(i, 3)) - 2), ",,", ",")
    
19.     Next
    
20.     [g2].Resize(n, 3) = brr
    
21. End Sub

复制代码

跳转到最佳答案楼层

Tank008

去重复没这么折腾。
用自带的“去除重复项”

grf1973

1. Sub 去重合并()
   
2.     arr = Range("a1:d" & [b65536].End(3).Row)
   
3.     ReDim brr(1 To UBound(arr), 1 To 3)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr)
   
6.         x = arr(i, 2) & arr(i, 3): y = "," & arr(i, 4) & ","
   
7.         If Not d.exists(x) Then
   
8.             n = n + 1: d(x) = n
   
9.             brr(n, 1) = arr(i, 2)
   
10.             brr(n, 2) = arr(i, 3)
    
11.         End If
    
12.         p = d(x)
    
13.         If Len(arr(i, 4)) > 0 Then
    
14.             If InStr(brr(p, 3), y) = 0 Then brr(p, 3) = brr(p, 3) & y
    
15.         End If
    
16.     Next
    
17.     For i = 1 To n
    
18.         brr(i, 3) = Replace(Mid(brr(i, 3), 2, Len(brr(i, 3)) - 2), ",,", ",")
    
19.     Next
    
20.     [g2].Resize(n, 3) = brr
    
21. End Sub

复制代码

grf1973

请看附件。