[已解决]关于排序汇总的问题请教论坛中的老师大神们

mind1238

每天重复要把很多数据汇总，自动汇总能解决一部分问题。但是自动汇总前提是先排序，排序的问题出来了，排序的话当中有很多选项，要后续人工再分开
这样很复杂，工作量也很大
请都大神们，用VBA编码给简单快捷的方法
详见附件，在线等
谢谢

附件已更新

最佳答案

月排行榜 / 总排行榜

grf1973

2016-1-20 10:58

1. Sub tt()
   
2.     arr = [a1].CurrentRegion
   
3.     ReDim brr(1 To UBound(arr), 1 To 6)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr) - 1
   
6.         x = Left(arr(i, 1), 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
   
7.         If Not d.exists(x) Then
   
8.             n = n + 1: d(x) = n
   
9.             brr(n, 1) = Left(arr(i, 1), 1): brr(n, 2) = arr(i, 2)
   
10.             brr(n, 3) = arr(i, 3): brr(n, 4) = arr(i, 4)
    
11.         End If
    
12.         p = d(x)
    
13.         brr(p, 5) = brr(p, 5) + arr(i, 5)
    
14.         brr(p, 6) = brr(p, 6) + arr(i, 6)
    
15.     Next
    
16.     With Sheet3
    
17.         .Cells.Clear
    
18.         .[a1].Resize(1, 6) = Array("等级", "长", "宽", "厚度", "件数", "方数")
    
19.         .[a2].Resize(n, 6) = brr
    
20.         .[a2].Resize(n, 6).Sort key1:=.[a2], key2:=.[b2], key3:=.[c2]
    
21.         arr = .[a2].Resize(n + 1, 6)    '排序后的源数组
    
22.         ReDim brr(1 To UBound(arr) + 100, 1 To 6)
    
23.         n = 0
    
24.         For i = 1 To UBound(arr) - 1       '分类汇总
    
25.            n = n + 1
    
26.            For j = 1 To 6: brr(n, j) = arr(i, j): Next
    
27.            s1 = s1 + arr(i, 5): s2 = s2 + arr(i, 6)
    
28.            If arr(i, 1) <> arr(i + 1, 1) Then
    
29.                 n = n + 1
    
30.                 brr(n, 1) = arr(i, 1) & "总计"
    
31.                 brr(n, 5) = s1: brr(n, 6) = s2
    
32.                 s1 = 0: s2 = 0
    
33.            End If
    
34.         Next
    
35.         .[a2].Resize(n, 6) = brr
    
36.         .Activate
    
37.     End With
    
38. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     arr = [a1].CurrentRegion
   
3.     ReDim brr(1 To UBound(arr), 1 To 6)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr) - 1
   
6.         x = Left(arr(i, 1), 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
   
7.         If Not d.exists(x) Then
   
8.             n = n + 1: d(x) = n
   
9.             brr(n, 1) = Left(arr(i, 1), 1): brr(n, 2) = arr(i, 2)
   
10.             brr(n, 3) = arr(i, 3): brr(n, 4) = arr(i, 4)
    
11.         End If
    
12.         p = d(x)
    
13.         brr(p, 5) = brr(p, 5) + arr(i, 5)
    
14.         brr(p, 6) = brr(p, 6) + arr(i, 6)
    
15.     Next
    
16.     With Sheet3
    
17.         .Cells.Clear
    
18.         .[a1].Resize(1, 6) = Array("等级", "长", "宽", "厚度", "件数", "方数")
    
19.         .[a2].Resize(n, 6) = brr
    
20.         .[a2].Resize(n, 6).Sort key1:=.[a2], key2:=.[b2], key3:=.[c2]
    
21.         arr = .[a2].Resize(n + 1, 6)    '排序后的源数组
    
22.         ReDim brr(1 To UBound(arr) + 100, 1 To 6)
    
23.         n = 0
    
24.         For i = 1 To UBound(arr) - 1       '分类汇总
    
25.            n = n + 1
    
26.            For j = 1 To 6: brr(n, j) = arr(i, j): Next
    
27.            s1 = s1 + arr(i, 5): s2 = s2 + arr(i, 6)
    
28.            If arr(i, 1) <> arr(i + 1, 1) Then
    
29.                 n = n + 1
    
30.                 brr(n, 1) = arr(i, 1) & "总计"
    
31.                 brr(n, 5) = s1: brr(n, 6) = s2
    
32.                 s1 = 0: s2 = 0
    
33.            End If
    
34.         Next
    
35.         .[a2].Resize(n, 6) = brr
    
36.         .Activate
    
37.     End With
    
38. End Sub

复制代码

心正意诚身修

汇总规则是什么
石的  3000  600  12的怎么不汇总

mind1238

grf1973 发表于 2016-1-20 10:58

{:221:}谢谢，是要这种结果，但是我想问一下为什么我把这个代码复制到别的表格中说“运行时错误“424”要求对象
这个我不懂，示赐教

grf1973

要把运行错误的附件发上来才知道的。可能是数组没读取到，或者Sheet3不存在之类的。用这个代码试试，新加表格用于运行计算结果。

1. Sub tt()
   
2.     arr = [a1].CurrentRegion
   
3.     ReDim brr(1 To UBound(arr), 1 To 6)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr) - 1
   
6.         x = Left(arr(i, 1), 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
   
7.         If Not d.exists(x) Then
   
8.             n = n + 1: d(x) = n
   
9.             brr(n, 1) = Left(arr(i, 1), 1): brr(n, 2) = arr(i, 2)
   
10.             brr(n, 3) = arr(i, 3): brr(n, 4) = arr(i, 4)
    
11.         End If
    
12.         p = d(x)
    
13.         brr(p, 5) = brr(p, 5) + arr(i, 5)
    
14.         brr(p, 6) = brr(p, 6) + arr(i, 6)
    
15.     Next
    
16.     Worksheets.Add after:=Sheets(Sheets.Count)
    
17.     With ActiveSheet
    
18.         .Cells.Clear
    
19.         .[a1].Resize(1, 6) = Array("等级", "长", "宽", "厚度", "件数", "方数")
    
20.         .[a2].Resize(n, 6) = brr
    
21.         .[a2].Resize(n, 6).Sort key1:=.[a2], key2:=.[b2], key3:=.[c2]
    
22.         arr = .[a2].Resize(n + 1, 6)    '排序后的源数组
    
23.         ReDim brr(1 To UBound(arr) + 100, 1 To 6)
    
24.         n = 0
    
25.         For i = 1 To UBound(arr) - 1       '分类汇总
    
26.            n = n + 1
    
27.            For j = 1 To 6: brr(n, j) = arr(i, j): Next
    
28.            s1 = s1 + arr(i, 5): s2 = s2 + arr(i, 6)
    
29.            If arr(i, 1) <> arr(i + 1, 1) Then
    
30.                 n = n + 1
    
31.                 brr(n, 1) = arr(i, 1) & "总计"
    
32.                 brr(n, 5) = s1: brr(n, 6) = s2
    
33.                 s1 = 0: s2 = 0
    
34.            End If
    
35.         Next
    
36.         .[a2].Resize(n, 6) = brr
    
37.     End With
    
38. End Sub
    

复制代码

mind1238

grf1973 发表于 2016-1-20 16:31
要把运行错误的附件发上来才知道的。可能是数组没读取到，或者Sheet3不存在之类的。用这个代码试试，新加表 ...

好的，谢谢。可以用。非常感谢你
还有就是有一个问题，就是能不有在选定的区域里汇总。
你做的代码就是我想要的结果，但是想到后面有可能会数据增加，比如在方数后面会增加金额，然后要怎么把金额那一项也汇总？
就是能不能在选定的区域内汇总，这样就不管我后面可能会增加多少列