多字段分类汇总问题

ykcbf1100

按日期和工艺分类汇总，增加小计、累计、总计，非公式法

ykcbf1100

1. Sub ykcbf()   '//2025.3.14
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     bt = 1: col = 1: c = 2: c1 = 3
   
5.     Dim zr(1 To 1000)
   
6.     br = [{"小计","累计"}]
   
7.     On Error Resume Next
   
8.     With ActiveSheet
   
9.         arr = .UsedRange
   
10.         For i = bt + 1 To UBound(arr)
    
11.             If InStr(arr(i, c), br(1)) Then
    
12.                 MsgBox "已有小计行，不必再插入！"
    
13.                 Exit Sub
    
14.             End If
    
15.         Next
    
16.         .Cells.Interior.ColorIndex = 0
    
17.         ReDim brr(1 To UBound(arr) * 2, 1 To 7)
    
18.         ReDim Sum(1 To 7)
    
19.         ReDim Ss(1 To 7)
    
20.         For i = bt + 1 To UBound(arr)
    
21.             If Month(arr(i, col)) & arr(i, 2) <> Month(arr(i - 1, col)) & arr(i - 1, 2) Then k = k + 1: zr(k) = Array(i, i)
    
22.             zr(k)(1) = i
    
23.         Next
    
24.         For x = 1 To k
    
25.             r1 = zr(x)(0): r2 = zr(x)(1)
    
26.             n = r2 - r1 + 1
    
27.             For i = r1 To r2
    
28.                 m = m + 1
    
29.                 For j = 1 To UBound(arr, 2)
    
30.                     brr(m, j) = arr(i, j)
    
31.                 Next
    
32.             Next
    
33.             m = m + 2
    
34.             brr(m - 1, 2) = Month(arr(r1, 1)) & "月" & arr(r1, 2) & br(1)
    
35.             brr(m, 2) = Month(arr(r1, 1)) & "月" & br(2)
    
36.             For j = c1 To UBound(arr, 2)
    
37.                 brr(m - 1, j) = Application.Sum(.Cells(r1, j).Resize(n))
    
38.                 Ss(j) = Ss(j) + brr(m - 1, j)
    
39.                 If x = 1 Or Month(arr(r2, col)) <> Month(arr(zr(x - 1)(1), col)) Then
    
40.                     brr(m, j) = brr(m - 1, j)
    
41.                     Sum(j) = brr(m - 1, j)
    
42.                 Else
    
43.                     Sum(j) = Sum(j) + brr(m - 1, j)
    
44.                 End If
    
45.                 brr(m, j) = Sum(j)
    
46.             Next
    
47.         Next
    
48.         m = m + 1
    
49.         brr(m, 2) = "总计"
    
50.         For j = c1 To UBound(arr, 2)
    
51.             brr(m, j) = Ss(j)
    
52.         Next
    
53.         With .Cells(bt + 1, 1).Resize(m, UBound(arr, 2))
    
54.             .Value = brr
    
55.             .Borders.LineStyle = 1
    
56.             .HorizontalAlignment = xlCenter
    
57.             .VerticalAlignment = xlCenter
    
58.         End With
    
59.         For i = bt + 1 To m + bt
    
60.             Set Rng = .Cells(i, c)
    
61.             If InStr(Rng.Value, "小计") Then
    
62.                 Rng.Resize(, 6).Interior.ColorIndex = 4
    
63.                 Rng.Offset(1).Resize(, 6).Interior.ColorIndex = 6
    
64.             End If
    
65.             If InStr(Rng.Value, "总计") Then
    
66.                 Rng.Resize(, 6).Interior.ColorIndex = 8
    
67.             End If
    
68.         Next
    
69.         ActiveWindow.DisplayZeros = False
    
70.     End With
    
71.     Application.ScreenUpdating = True
    
72.     MsgBox "OK！"
    
73. End Sub
    
74. 
    
75. Sub 删除小计()
    
76.     With ActiveSheet
    
77.         bt = 2: col = 2
    
78.         r = .Cells(.Rows.Count, col).End(xlUp).Row
    
79.         Set Rng = Nothing
    
80.         For i = bt + 1 To r
    
81.             If InStr(.Cells(i, col), "计") Then
    
82.                 If Rng Is Nothing Then
    
83.                     Set Rng = .Rows(i)
    
84.                 Else
    
85.                     Set Rng = Union(Rng, .Rows(i))
    
86.                 End If
    
87.             End If
    
88.         Next
    
89.         If Not Rng Is Nothing Then Rng.EntireRow.Delete
    
90.     End With
    
91. End Sub
    

复制代码

opiona

使用数组实现合计小计累计总计,并条件格式显示
https://club.excelhome.net/thread-1712622-1-1.html