求助大神，开支进行分类汇总求和，并以颜色进行区别

dantemis

如附件，要将表1变成表2，按照类别进行汇总求和，并以颜色进行视觉上区别以便直观，谢谢大神们帮忙！！

3190496160

Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r < 4 Then MsgBox "数据源为空！": End
    ar = .Range("b3:w" & r)
End With
For i = 2 To UBound(ar)
    If ar(i, 2) <> "" Then
        s = ar(i, 2)
        If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
        d(s)(i) = ""
    End If
Next i
With Sheet2
    .UsedRange.Offset(3).Borders.LineStyle = 0
    .UsedRange.Offset(3).Interior.ColorIndex = 0
    .UsedRange.Offset(3).UnMerge
    .UsedRange.Offset(3) = Empty
    w = 15
    For Each k In d.keys
        n = 0: hj = 0
        ReDim br(1 To d(k).Count, 1 To UBound(ar, 2))
        For Each kk In d(k).keys
            n = n + 1
            For j = 1 To UBound(ar, 2)
                br(n, j) = ar(kk, j)
            Next j
            hj = hj + ar(kk, 19)
        Next kk
        rs = .Cells(Rows.Count, 2).End(xlUp).Row + 1
        .Cells(rs, 2).Resize(n, UBound(br, 2)) = br
        .Cells(rs, 2).Resize(n, UBound(br, 2)).Borders.LineStyle = 1
        .Cells(rs, 23).Resize(n, 1).Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .MergeCells = False
        End With
        Selection.Merge
        .Cells(rs, 23) = hj
        .Cells(rs, 2).Resize(n, UBound(br, 2)).Interior.ColorIndex = w
        w = w + 1
    Next k
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

开支明细分类汇总1.rar (25.07 KB, 下载次数: 1)

2024-11-29 09:40 上传

点击文件名下载附件

dantemis

3190496160 发表于 2024-11-29 09:40

感谢！感谢大神的顶力帮助，您太厉害了！！！