分类汇总

ykcbf1100

上次代码小改一下即可。

ykcbf1100

分类汇总。。。

1. Sub ykcbf()  '//2024.7.11  分类汇总
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("Sheet1")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 7)
   
7.     End With
   
8.     ReDim brr(1 To UBound(arr), 1 To 9)
   
9.     b = [{2,3,5}]
   
10.     For j = 1 To UBound(b)
    
11.         d.RemoveAll
    
12.         m = 0
    
13.         n = n + 3
    
14.         For i = 3 To UBound(arr)
    
15.             s = arr(i, b(j))
    
16.             If Not d.exists(s) Then
    
17.                 m = m + 1
    
18.                 d(s) = m
    
19.                 brr(m, n - 2) = s
    
20.                 brr(m, n - 1) = 1
    
21.                 brr(m, n) = arr(i, 6)
    
22.             Else
    
23.                 r = d(s)
    
24.                 brr(r, n - 1) = brr(r, n - 1) + 1
    
25.                 brr(r, n) = brr(r, n) + arr(i, 6)
    
26.             End If
    
27.         Next
    
28.         Max = IIf(Max < m, m, Max)
    
29.     Next
    
30.     With Sheets("Sheet2")
    
31.         .UsedRange.Offset(1).Clear
    
32.         .[a1].Resize(1, 9).Interior.Color = 49407
    
33.         With .[a2].Resize(Max + 1, 9)
    
34.             .Value = brr
    
35.             .Borders.LineStyle = 1
    
36.             .HorizontalAlignment = xlCenter
    
37.             .VerticalAlignment = xlCenter
    
38.         End With
    
39.         r = Max + 1
    
40.         For j = 2 To 9
    
41.             .Cells(r + 1, j) = Application.Sum(.Cells(2, j).Resize(Max))
    
42.         Next
    
43.         For j = 1 To 7 Step 3
    
44.             .Cells(r + 1, j) = "合计"
    
45.         Next
    
46.         .Cells(r + 1, 1).Resize(, 9).Interior.ColorIndex = 6
    
47.         ActiveWindow.DisplayZeros = False
    
48.     End With
    
49.     Set d = Nothing
    
50.     Application.ScreenUpdating = True
    
51.     MsgBox "OK！"
    
52. End Sub
    

复制代码

wkxxxr

ykcbf1100 发表于 2024-7-11 13:12
上次代码小改一下即可。

非常谢谢！

wkxxxr

3190496160 发表于 2024-7-11 10:39

非常感谢！

wkxxxr

Qs18 发表于 2024-7-11 11:34
试试.........

非常感谢！

grf1973

可以写成函数，以分类依据为参数，返回汇总后的数组，这样可以大大简化代码。

grf1973

参与一下。。。。。

wkxxxr

grf1973 发表于 2024-7-11 15:35
参与一下。。。。。

十分谢谢！

ph378

学习学习学习再学习！