多字段分类汇总问题

Laughingsun889

tel3033 发表于 2022-6-7 15:36

谢谢老师，辛苦了，是我想要的结果！

Laughingsun889

鄂龙蒙 发表于 2022-6-7 16:07

谢谢老师！虽没有达到我的要求，但已经很好了！

Laughingsun889

wxxydl 发表于 2022-6-7 18:20
我给你做了一个  看一下是这样的吗

是这样的，谢谢老师，辛苦了！

Laughingsun889

wowo000 发表于 2022-6-7 17:21
您的附件没问题。只不过没完全符合楼主的要求。可否改进？？

谢谢老师关注！

xiangbaoan

1. Sub test1() '若A、B 列有序
   
2.   Dim ar, i As Long, j As Long, k As Long
   
3.   ar = Sheet1.Range("A1").CurrentRegion.Offset(1)
   
4.   ReDim br(1 To UBound(ar) * 2, 1 To UBound(ar, 2))
   
5.   ReDim a(3 To UBound(ar, 2)) As Double
   
6.   ReDim b(3 To UBound(ar, 2)) As Double
   
7.   ReDim c(3 To UBound(ar, 2)) As Double
   
8.   ar(UBound(ar), 1) = DateAdd("m", 1, ar(UBound(ar) - 1, 1))
   
9.   For i = 1 To UBound(ar) - 1
   
10.     k = k + 1
    
11.     For j = 1 To UBound(ar, 2)
    
12.       br(k, j) = ar(i, j)
    
13.       If j > 2 Then
    
14.         a(j) = a(j) + ar(i, j)
    
15.         b(j) = b(j) + ar(i, j)
    
16.         c(j) = c(j) + ar(i, j)
    
17.       End If
    
18.     Next
    
19.     If Month(ar(i, 1)) & ar(i, 2) <> Month(ar(i + 1, 1)) & ar(i + 1, 2) Then
    
20.       k = k + 1
    
21.       br(k, 2) = "小计"
    
22.       For j = 3 To UBound(br, 2)
    
23.         br(k, j) = a(j)
    
24.         a(j) = 0
    
25.       Next
    
26.     End If
    
27.     If Month(ar(i, 1)) <> Month(ar(i + 1, 1)) Then
    
28.       k = k + 1
    
29.       br(k, 2) = "合计"
    
30.       For j = 3 To UBound(br, 2)
    
31.         br(k, j) = b(j)
    
32.         b(j) = 0
    
33.       Next
    
34.     End If
    
35.   Next
    
36.   k = k + 1
    
37.   br(k, 2) = "总计"
    
38.   For j = 3 To UBound(br, 2)
    
39.     br(k, j) = c(j)
    
40.   Next
    
41.   Sheet2.Range("A2").Resize(k, UBound(br, 2)) = br
    
42. End Sub

复制代码

准提部林

沒詳細看, 大約做個//
模擬的合計有點不懂
XX20220607.rar (19.66 KB, 下载次数: 21)

2022-6-7 20:46 上传

点击文件名下载附件

wowo000

准提部林 发表于 2022-6-7 20:47
沒詳細看, 大約做個//
模擬的合計有點不懂

尊敬的准提部林老师：可否将最后的排序代码应用数组里排序好后再整体输出到sheet2工作表里？？劳烦！

Laughingsun889

准提部林 发表于 2022-6-7 20:47
沒詳細看, 大約做個//
模擬的合計有點不懂

谢谢老师，辛苦了！

准提部林

wowo000 发表于 2022-6-7 21:10
尊敬的准提部林老师：可否将最后的排序代码应用数组里排序好后再整体输出到sheet2工作表里？？劳烦！

數組排序例子多得是, 找一即可!
能用工作表排序, 就不用數組, 反而不直觀又沒效率~~

ZHLK

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
If CommandButton1.Caption = "小计合计" Then
    CommandButton1.Caption = "清除"
    '先排序
    i = Range("b65536").End(xlUp).Row
    ActiveWorkbook.Worksheets("原表").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("原表").Sort.SortFields.Add Key:=Range("A2:A" & i), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("原表").Sort.SortFields.Add Key:=Range("B2:B" & i), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("原表").Sort
        .SetRange Range("A1:G" & i)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    '开始计算
    Columns("A:A").Insert Shift:=xlToRight
    Range("A1") = "月份"
    For i = 2 To 57
        Cells(i, 1) = Format(Cells(i, 2), "yyyy-mm")
    Next i
   
    Range("A1:H" & Range("A65320").End(xlUp).Row).Select
    Range("A1").CurrentRegion.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4, 5, 6, _
        7, 8), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    For i = 2 To Range("A65320").End(xlUp).Row
        If InStr(Cells(i, 1), "汇总") Then
            Cells(i, 3) = "合计"
            Cells(i, 3).Font.Bold = True
        End If
    Next i
        
    Range("A1").CurrentRegion.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(4, 5, 6, 7, _
        8), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
    For i = 2 To Range("A65320").End(xlUp).Row
        If InStr(Cells(i, 3), "汇总") Then
            Cells(i, 3) = "小计"
             Cells(i, 3).Font.Bold = True
        End If
    Next i
    Cells(Range("A65320").End(xlUp).Row, 3) = Cells(Range("A65320").End(xlUp).Row, 1)
    Cells(Range("A65320").End(xlUp).Row, 3).Font.Bold = True
    Columns("A:A").Delete Shift:=xlToLeft
   
Else
    Range("A1").CurrentRegion.RemoveSubtotal
    CommandButton1.Caption = "小计合计"
End If

Range("A1").CurrentRegion.Borders.LineStyle = 1
Range("A1").Select

Application.ScreenUpdating = True

End Sub