根据表一的数据，按照日期+中断类型形成汇总

chenhong0973

各位老师，最近在学习VBA，请教各位高手老师，如何根据表一的数据，能够像实现效果表中，按照日期+中断类型进行分类汇总。恳请各位老师帮忙，谢谢！

shiruiqiang

小白路过，字典嵌套

3190496160

Sub 分类汇总()
Application.ScreenUpdating = False
Dim d As Object
Dim ar As Variant
Dim br()
tt = Timer
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 4 Then MsgBox "数据源为空！": End
    ar = .Range("A1:ab" & r)
End With
For i = 4 To UBound(ar)
    If ar(i, 1) <> "" Then
        If IsDate(ar(i, 1)) Then
            s = Month(ar(i, 1))
            If Not d.Exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
            d(s)(i) = i
        End If
    End If
Next i
With Sheets("实现效果")
    .UsedRange.Offset(3).Borders.LineStyle = 0
    .UsedRange.Offset(3).Interior.ColorIndex = 0
    .UsedRange.Offset(3) = Empty
    For Each k In d.keys
        m = 0
        dc.RemoveAll
        ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
        For Each kk In d(k).keys
            zd = ar(kk, 1) & "|" & ar(kk, 11)
            t = dc(zd)
            If t = "" Then
                m = m + 1
                dc(zd) = m
                t = m
                For j = 1 To 10
                    br(m, j) = ar(kk, j)
                Next j
                For j = 11 To 21 Step 2
                    br(m, j) = ar(kk, j)
                Next j
                br(m, 23) = ar(kk, 23)
            End If
            For j = 12 To 22 Step 2
                br(t, j) = br(t, j) + ar(kk, j)
            Next j
            For j = 24 To 28 Step 1
                br(t, j) = br(t, j) + ar(kk, j)
            Next j
        Next kk
        rs = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        If rs < 4 Then
            rs = 4
        Else
            rs = rs
        End If
        .Cells(rs, 1).Resize(m, UBound(br, 2)) = br
        .Cells(rs, 1).Resize(m + 1, UBound(br, 2)).Borders.LineStyle = 1
        .Cells(rs + m, 1) = k & " 汇总"
        .Cells(rs + m, 1).Resize(1, UBound(br, 2)).Interior.ColorIndex = 23
        For j = 12 To 22 Step 2
            .Cells(rs + m, j) = Application.Sum(Application.Index(br, 0, j))
        Next j
        For j = 24 To 28 Step 1
            .Cells(rs + m, j) = Application.Sum(Application.Index(br, 0, j))
        Next j
    Next k
End With
Application.ScreenUpdating = True
MsgBox "用时" & Format(Timer - tt, "0.00") & "秒"
End Sub

3190496160

新建 Microsoft Excel 工作表.rar (52.88 KB, 下载次数: 9)

2024-4-23 08:32 上传

点击文件名下载附件

3190496160

前后表述自相矛盾，代码仅供参考

ykcbf1100

shiruiqiang 发表于 2024-4-22 22:14
小白路过，字典嵌套

这么谦虚啊

shiruiqiang

ykcbf1100 发表于 2024-4-23 09:51
这么谦虚啊

vba靠兴趣自学，发现很多知识需要系统地完成。
一开始是靠学习群里各位老师的代码，并尝试理解，并修改完成。
后来慢慢用到实际来提升，感觉真的靠多写代码、多看各位老师的思路才受益匪浅。
（特别是前3年各种数据、报表的汇总、整理提升了效率。）
在此感谢各位老师。

chenhong0973

3190496160 发表于 2024-4-23 08:33
前后表述自相矛盾，代码仅供参考

老师，是我的表达的不清楚，我想表达的是，表一是个总表，然后在实现效果中，可以实现按照月份+中断类型进行分类汇总，并进行统计，您指导的，已经实现了按照月份的汇总了。谢谢您！

ykcbf1100

参与一下，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.23
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("实现效果")
   
5.     With Sheets("Sheet1")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         c = .UsedRange.Columns.Count
   
8.         arr = .[a1].Resize(r, c)
   
9.     End With
   
10.     For i = 4 To UBound(arr)
    
11.         s = Month(arr(i, 1)) & "|" & arr(i, 10)
    
12.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
13.         d(s)(i) = i
    
14.     Next
    
15.     ReDim brr(1 To 10000, 1 To c)
    
16.     b = [{12,14,16,18,20,22,24,25,26,27}]
    
17.     m = 0
    
18.     For Each k In d.keys
    
19.         n = 0
    
20.         For Each kk In d(k).keys
    
21.             m = m + 1: n = n + 1
    
22.             If n = 1 Then r1 = m
    
23.             For j = 1 To UBound(arr, 2)
    
24.                 brr(m, j) = arr(kk, j)
    
25.             Next
    
26.         Next
    
27.         m = m + 1
    
28.         brr(m, 1) = Split(k, "|")(0) & "月汇总"
    
29.         For y = r1 To r1 + d(k).Count - 1
    
30.             For x = 1 To UBound(b)
    
31.                 brr(m, b(x)) = brr(m, b(x)) + brr(y, b(x))
    
32.             Next
    
33.         Next
    
34.     Next
    
35.     With sh
    
36.         .UsedRange.Offset(3).ClearContents
    
37.         .UsedRange.Offset(3).Interior.ColorIndex = 0
    
38.         .Range("X:AA").NumberFormatLocal = "@"
    
39.         With .[a4].Resize(m, c - 1)
    
40.             .Value = brr
    
41.             .Borders.LineStyle = 1
    
42.             .HorizontalAlignment = xlCenter
    
43.             .VerticalAlignment = xlCenter
    
44.         End With
    
45.         .Rows("4:4").Copy
    
46.         .Rows("5:" & m + 3).PasteSpecial Paste:=xlPasteFormats
    
47.         Application.CutCopyMode = False
    
48.         .[e6].Select
    
49.     End With
    
50.     Set d = Nothing
    
51.     Application.ScreenUpdating = True
    
52.     MsgBox "OK！"
    
53. End Sub
    
54. 
    

复制代码