求助：按类别分页小计

CNS1993

求助：按“类目”分页小计，谢谢！ 按类目分页小计.zip (2.27 KB, 下载次数: 20)

2022-12-6 12:20 上传

点击文件名下载附件

ykcbf1100

没看懂你的需求。
代码仅指增加小计和总计

liulang0808

Sub 按钮2_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For j = 3 To UBound(arr)
        d(arr(j, 1)) = d(arr(j, 1)) & "," & j
    Next j
    r = 3
    x = 0
    For Each kk In d.keys
        brr = Split(d(kk), ",")
        For i = 1 To UBound(brr) Step 3
            For j = 0 To 2
                If i + j <= UBound(brr) Then
                    r1 = r + j
                    For k = 1 To 5
                        Cells(r1, k + 7) = arr(Val(brr(i + j)), k)
                        Cells(r + 4, k + 7) = Val(Cells(r + 4, k + 7)) + Val(Cells(r1, k + 7))
                    Next k
                End If
            Next j
            r = r + 5
            Cells(r - 1, 8) = "小计"
        Next i
    Next
End Sub

liulang0808

最后的合计，自己添加吧

3190496160

Sub xiaoji()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim rng As Range
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
     r = .Cells(Rows.Count, 1).End(xlUp).Row
     ar = .[a1].CurrentRegion
     Set rng = .Rows(2)
    For i = 3 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            d(Trim(ar(i, 1))) = ""
        End If
    Next i
End With
With Sheets("结果")
    .UsedRange.Clear
    rng.Copy .[a1]
    rs = 2
    For Each k In d.keys
        n = 0
        ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
        For i = 3 To UBound(ar)
            If Trim(ar(i, 1)) = k Then
                n = n + 1
                For j = 1 To UBound(ar, 2)
                    br(n, j) = ar(i, j)
                Next j
            End If
        Next i
        If n <= 3 Then
            .Cells(rs, 1).Resize(n, UBound(br, 2)) = br
            .Cells(rs + 4, 1) = "小计"
            For j = 2 To UBound(br, 2)
                .Cells(rs + 4, j) = Application.Sum(Application.Index(br, 0, j))
            Next j
            rs = rs + 5
        Else
            For i = 1 To n Step 3
                m = rs - 1
                For s = i To i + 2
                    If s <= n Then
                        m = m + 1
                        For j = 1 To UBound(br, 2)
                            .Cells(m, j) = br(i, j)
                        Next j
                    End If
                Next s
                 .Cells(rs + 4, 1) = "小计"
                For j = 2 To UBound(br, 2)
                    .Cells(rs + 4, j) = Application.Sum(.Range(.Cells(rs, j), .Cells(rs + 3, j)))
                Next j
                rs = rs + 5
            Next i
        End If
    Next k
    .Select
End With
MsgBox "ok!"
End Sub

3190496160

按类目分页小计11.rar (17.17 KB, 下载次数: 8)

2022-12-6 14:15 上传

点击文件名下载附件

3190496160

增加了  总计，以此附件为准
按类目分页小计11.rar (16.79 KB, 下载次数: 23)

2022-12-6 14:20 上传

点击文件名下载附件

fzxba

1. Sub test1()
   
2.   Dim vData, vResult(), vTotal() As Double, i As Long, j As Integer
   
3.   Dim rowSize As Long, posRow As Long, iCount As Integer
   
4.   vData = Range("E3", Cells(Rows.Count, "A").End(xlUp).Offset(1))
   
5.   ReDim vResult(1 To 10000, 1 To UBound(vData, 2)), vTotal(2 To UBound(vData, 2))
   
6.   QuickSort vData, 1, UBound(vData) - 1, 1, UBound(vData, 2), 1
   
7.   posRow = 5
   
8.   vResult(posRow, 1) = "小计"
   
9.   For i = 1 To UBound(vData) - 1
   
10.     rowSize = rowSize + 1
    
11.     iCount = iCount + 1
    
12.     For j = 1 To UBound(vData, 2)
    
13.       vResult(rowSize, j) = vData(i, j)
    
14.       If j > 1 Then
    
15.         vResult(posRow, j) = vResult(posRow, j) + vData(i, j)
    
16.         vTotal(j) = vTotal(j) + vData(i, j)
    
17.       End If
    
18.     Next
    
19.     If iCount = 3 Then
    
20.       rowSize = posRow
    
21.       posRow = posRow + 5
    
22.       vResult(posRow, 1) = "小计"
    
23.       iCount = 0
    
24.     Else
    
25.       If vData(i, 1) <> vData(i + 1, 1) Then
    
26.         rowSize = posRow
    
27.         posRow = posRow + 5
    
28.         vResult(posRow, 1) = "小计"
    
29.         iCount = 0
    
30.       End If
    
31.     End If
    
32.   Next
    
33.   vResult(posRow - 4, 1) = "总合计"
    
34.   For j = LBound(vTotal) To UBound(vTotal)
    
35.     vResult(posRow - 4, j) = vTotal(j)
    
36.   Next
    
37.   With Range("I3")
    
38.     .Resize(Rows.Count - .Row, UBound(vResult, 2)).ClearContents
    
39.     .Resize(posRow - 4, UBound(vResult, 2)) = vResult
    
40.   End With
    
41.   Beep
    
42. End Sub
    
43. 
    
44. Function QuickSort(ar, u As Long, d As Long, l As Long, r As Long, pos As Long)
    
45.   Dim up As Long, dn As Long, x As Long, sPivot As String, vSwap
    
46.   up = u
    
47.   dn = d
    
48.   sPivot = ar((u + d) \ 2, pos)
    
49.   While up <= dn
    
50.     Do While up < d
    
51.       If StrComp(ar(up, pos), sPivot, vbTextCompare) = -1 Then up = up + 1 Else Exit Do
    
52.     Loop
    
53.     Do While dn > u
    
54.       If StrComp(sPivot, ar(dn, pos), vbTextCompare) = -1 Then dn = dn - 1 Else Exit Do
    
55.     Loop
    
56.     If up < dn Then
    
57.       For x = l To r
    
58.         vSwap = ar(up, x): ar(up, x) = ar(dn, x): ar(dn, x) = vSwap
    
59.       Next
    
60.       up = up + 1: dn = dn - 1
    
61.     Else
    
62.       If up = dn Then up = up + 1: dn = dn - 1
    
63.     End If
    
64.   Wend
    
65.   If up < d Then QuickSort ar, up, d, l, r, pos
    
66.   If dn > u Then QuickSort ar, u, dn, l, r, pos
    
67. End Function

复制代码

fzxba

按类目分页小计_改进.rar (17.62 KB, 下载次数: 18)

2022-12-6 15:59 上传

点击文件名下载附件

CNS1993

3190496160 发表于 2022-12-6 14:20
增加了  总计，以此附件为准

            For I = 1 To N Step 3
                M = rs - 1
                For s = I To I + 2
                    If s <= N Then
                        M = M + 1
                        For j = 1 To UBound(br, 2)
                            .Cells(M, j) = br(I, j)
                        Next j
                    End If
                Next s
                 .Cells(rs + 4, 1) = "小计"
br(I, j)好像没对。麻烦了