老师求解，谢谢！

神往之地

请查看附件中的想要达成的结果，感谢！

hyfire2008

QINGJAO.zip (8.49 KB, 下载次数: 6)

2019-8-6 21:41 上传

点击文件名下载附件

大灰狼1976

1. Sub test()
   
2. Dim d As Object, arr, arrRst, i&, r&, s$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [a1].CurrentRegion
   
5. ReDim arrRst(1 To UBound(arr), 1 To 2)
   
6. For i = 2 To UBound(arr)
   
7.   s = arr(i, 1)
   
8.   If Not d.exists(s) Then
   
9.     r = r + 1
   
10.     d(s) = r
    
11.     arrRst(r, 1) = s
    
12.     arrRst(r, 2) = arr(i, 4)
    
13.   Else
    
14.     arrRst(d(s), 2) = arrRst(d(s), 2) & "," & arr(i, 4)
    
15.   End If
    
16. Next i
    
17. [i2].Resize(r, 2) = arrRst
    
18. End Sub

复制代码

神往之地

大灰狼1976 发表于 2019-8-8 22:16

谢谢！！