[已解决]组数据归类的问题

Baibdu

附件 组数据归类.rar (8.39 KB, 下载次数: 10)

2014-11-27 19:28 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-1 10:58

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, n&, sz%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
   
5. For i = 1 To UBound(arr) Step 3
   
6.     If Not d.exists(arr(i, 1)) Then
   
7.         d(arr(i, 1)) = arr(i + 1, 1)
   
8.     Else
   
9.         d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i + 1, 1)
   
10.     End If
    
11. Next
    
12. ReDim brr(1 To d.Count * 3, 1 To 200)
    
13. For i = 0 To d.Count - 1
    
14.     sz = Application.Small(d.keys, i + 1)
    
15.     x = Split(d(sz), ",")
    
16.     If n < UBound(x) + 1 Then n = UBound(x) + 1
    
17.     For j = 0 To UBound(x)
    
18.         brr(i * 3 + 1, j + 1) = sz
    
19.         brr(i * 3 + 2, j + 1) = x(j)
    
20.     Next
    
21. Next
    
22. Range("u1").Resize(UBound(brr), n) = brr
    
23. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, n&, sz%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
   
5. For i = 1 To UBound(arr) Step 3
   
6.     If Not d.exists(arr(i, 1)) Then
   
7.         d(arr(i, 1)) = arr(i + 1, 1)
   
8.     Else
   
9.         d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i + 1, 1)
   
10.     End If
    
11. Next
    
12. ReDim brr(1 To d.Count * 3, 1 To 200)
    
13. For i = 0 To d.Count - 1
    
14.     sz = Application.Small(d.keys, i + 1)
    
15.     x = Split(d(sz), ",")
    
16.     If n < UBound(x) + 1 Then n = UBound(x) + 1
    
17.     For j = 0 To UBound(x)
    
18.         brr(i * 3 + 1, j + 1) = sz
    
19.         brr(i * 3 + 2, j + 1) = x(j)
    
20.     Next
    
21. Next
    
22. Range("u1").Resize(UBound(brr), n) = brr
    
23. End Sub

复制代码