[已解决]求助分类汇总

ms967967

求助数据的分类汇总。
附件在楼下

最佳答案

月排行榜 / 总排行榜

dsmch

2015-2-25 22:09

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, s&, n&, zf$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. ReDim brr(1 To 20000, 1 To 3)
   
6. For j = 2 To UBound(arr, 2)
   
7.     For i = 2 To UBound(arr)
   
8.         If arr(i, j) <> "" Then
   
9.             zf = arr(1, j) & "," & arr(i, j)
   
10.             If Not d.exists(zf) Then
    
11.                 s = s + 1
    
12.                 d(zf) = s
    
13.                 brr(s, 1) = arr(1, j)
    
14.                 brr(s, 2) = arr(i, j)
    
15.                 brr(s, 3) = arr(i, 1)
    
16.             Else
    
17.                 n = d(zf)
    
18.                 brr(n, 3) = brr(n, 3) + arr(i, 1)
    
19.             End If
    
20.         End If
    
21.     Next
    
22. Next
    
23. [i1:k1] = Array("名称", "内容", "总数量")
    
24. Range("i2").Resize(s, 3) = brr
    
25. Range("i1").Resize(s + 1, 3).Borders.LineStyle = 1
    
26. End Sub

复制代码

跳转到最佳答案楼层

ms967967

信息汇总.rar (9.11 KB, 下载次数: 28)

2015-2-25 19:35 上传

点击文件名下载附件

baksy

ms967967 发表于 2015-2-25 19:35

附件

ms967967

baksy 发表于 2015-2-25 20:29
附件

感谢baksy老师的帮助。
很对不起，我没有说明白，因为我的数据较多，而且经常要更新，希望老师给写的VB版的答案。
谢谢各位老师一直以来的帮助。

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, s&, n&, zf$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. ReDim brr(1 To 20000, 1 To 3)
   
6. For j = 2 To UBound(arr, 2)
   
7.     For i = 2 To UBound(arr)
   
8.         If arr(i, j) <> "" Then
   
9.             zf = arr(1, j) & "," & arr(i, j)
   
10.             If Not d.exists(zf) Then
    
11.                 s = s + 1
    
12.                 d(zf) = s
    
13.                 brr(s, 1) = arr(1, j)
    
14.                 brr(s, 2) = arr(i, j)
    
15.                 brr(s, 3) = arr(i, 1)
    
16.             Else
    
17.                 n = d(zf)
    
18.                 brr(n, 3) = brr(n, 3) + arr(i, 1)
    
19.             End If
    
20.         End If
    
21.     Next
    
22. Next
    
23. [i1:k1] = Array("名称", "内容", "总数量")
    
24. Range("i2").Resize(s, 3) = brr
    
25. Range("i1").Resize(s + 1, 3).Borders.LineStyle = 1
    
26. End Sub

复制代码

pengyx

ms967967 发表于 2015-2-25 20:56
感谢baksy老师的帮助。
很对不起，我没有说明白，因为我的数据较多，而且经常要更新，希望老师给写的VB版 ...

不知是不是你要的，不是就删了

pengyx

排序有点不一样，行不？