深夜薅不动头发了，前来求助，数据汇总

zhangzhezy

问题都在案例里，希望高手解答，万分感谢！


案例.zip (69.25 KB, 下载次数: 17)

2024-3-15 02:11 上传

点击文件名下载附件

或帮看看一下代码怎么简写，学习一下（我这屎山代码）

1. Sub 数据刷新_账目统计()
   
2.     Dim i As Long
   
3.     Dim wa As Worksheet, ws As Worksheet
   
4.     Dim arr As Variant
   
5. 
   
6.     Set wa = Sheets("账目统计")
   
7.     Set ws = Sheets("月流水库")
   
8.     arr = ws.Range("A1:G2401").Value
   
9.     wa.Range("C3:N9") = ""
   
10.     '1月汇总
    
11.     sum = 0: sum2 = 0: sum3 = 0: sum4 = 0: sum5 = 0
    
12.     For i = 2 To 2401
    
13.         If Month(arr(i, 3)) = wa.Range("C2") And arr(i, 4) = wa.Range("B4") And arr(i, 5) = "结算进账" Then
    
14.             sum = sum + arr(i, 6): End If
    
15.         If Month(arr(i, 3)) = wa.Range("C2") And arr(i, 4) = wa.Range("B5") And arr(i, 5) = "结算进账" Then
    
16.             sum2 = sum2 + arr(i, 6): End If
    
17.         If Month(arr(i, 3)) = wa.Range("C2") And arr(i, 4) = wa.Range("B6") And arr(i, 5) = "结算进账" Then
    
18.             sum3 = sum3 + arr(i, 6): End If
    
19.         If Month(arr(i, 3)) = wa.Range("C2") And arr(i, 4) = wa.Range("B7") And arr(i, 5) = "结算进账" Then
    
20.             sum4 = sum4 + arr(i, 6): End If
    
21.         If Month(arr(i, 3)) = wa.Range("C2") And arr(i, 4) = wa.Range("B8") And arr(i, 5) = "结算进账" Then
    
22.             sum5 = sum5 + arr(i, 6): End If
    
23.     Next:
    
24.     wa.Range("C4").Value = sum
    
25.     wa.Range("C5").Value = sum2
    
26.     wa.Range("C6").Value = sum3
    
27.     wa.Range("C7").Value = sum4
    
28.     wa.Range("C8").Value = sum5
    
29.     '2月汇总
    
30.     sum = 0: sum2 = 0: sum3 = 0: sum4 = 0: sum5 = 0
    
31.     For i = 2 To 2401
    
32.         If Month(arr(i, 3)) = wa.Range("D2") And arr(i, 4) = wa.Range("B4") And arr(i, 5) = "结算进账" Then
    
33.             sum = sum + arr(i, 6): End If
    
34.         If Month(arr(i, 3)) = wa.Range("D2") And arr(i, 4) = wa.Range("B5") And arr(i, 5) = "结算进账" Then
    
35.             sum2 = sum2 + arr(i, 6): End If
    
36.         If Month(arr(i, 3)) = wa.Range("D2") And arr(i, 4) = wa.Range("B6") And arr(i, 5) = "结算进账" Then
    
37.             sum3 = sum3 + arr(i, 6): End If
    
38.         If Month(arr(i, 3)) = wa.Range("D2") And arr(i, 4) = wa.Range("B7") And arr(i, 5) = "结算进账" Then
    
39.             sum4 = sum4 + arr(i, 6): End If
    
40.         If Month(arr(i, 3)) = wa.Range("D2") And arr(i, 4) = wa.Range("B8") And arr(i, 5) = "结算进账" Then
    
41.             sum5 = sum5 + arr(i, 6): End If
    
42.     Next:
    
43.     wa.Range("D4").Value = sum
    
44.     wa.Range("D5").Value = sum2
    
45.     wa.Range("D6").Value = sum3
    
46.     wa.Range("D7").Value = sum4
    
47.     wa.Range("D8").Value = sum5
    
48.     '3月汇总
    
49.     sum = 0: sum2 = 0: sum3 = 0: sum4 = 0: sum5 = 0
    
50.     For i = 2 To 2401
    
51.         If Month(arr(i, 3)) = wa.Range("E2") And arr(i, 4) = wa.Range("B4") And arr(i, 5) = "结算进账" Then
    
52.             sum = sum + arr(i, 6): End If
    
53.         If Month(arr(i, 3)) = wa.Range("E2") And arr(i, 4) = wa.Range("B5") And arr(i, 5) = "结算进账" Then
    
54.             sum2 = sum2 + arr(i, 6): End If
    
55.         If Month(arr(i, 3)) = wa.Range("E2") And arr(i, 4) = wa.Range("B6") And arr(i, 5) = "结算进账" Then
    
56.             sum3 = sum3 + arr(i, 6): End If
    
57.         If Month(arr(i, 3)) = wa.Range("E2") And arr(i, 4) = wa.Range("B7") And arr(i, 5) = "结算进账" Then
    
58.             sum4 = sum4 + arr(i, 6): End If
    
59.         If Month(arr(i, 3)) = wa.Range("E2") And arr(i, 4) = wa.Range("B8") And arr(i, 5) = "结算进账" Then
    
60.             sum5 = sum5 + arr(i, 6): End If
    
61.     Next:
    
62.     wa.Range("E4").Value = sum
    
63.     wa.Range("E5").Value = sum2
    
64.     wa.Range("E6").Value = sum3
    
65.     wa.Range("E7").Value = sum4
    
66.     wa.Range("E8").Value = sum5
    
67.     '4月汇总
    
68.     sum = 0: sum2 = 0: sum3 = 0: sum4 = 0: sum5 = 0
    
69.     For i = 2 To 2401
    
70.         If Month(arr(i, 3)) = wa.Range("F2") And arr(i, 4) = wa.Range("B4") And arr(i, 5) = "结算进账" Then
    
71.             sum = sum + arr(i, 6): End If
    
72.         If Month(arr(i, 3)) = wa.Range("F2") And arr(i, 4) = wa.Range("B5") And arr(i, 5) = "结算进账" Then
    
73.             sum2 = sum2 + arr(i, 6): End If
    
74.         If Month(arr(i, 3)) = wa.Range("F2") And arr(i, 4) = wa.Range("B6") And arr(i, 5) = "结算进账" Then
    
75.             sum3 = sum3 + arr(i, 6): End If
    
76.         If Month(arr(i, 3)) = wa.Range("F2") And arr(i, 4) = wa.Range("B7") And arr(i, 5) = "结算进账" Then
    
77.             sum4 = sum4 + arr(i, 6): End If
    
78.         If Month(arr(i, 3)) = wa.Range("F2") And arr(i, 4) = wa.Range("B8") And arr(i, 5) = "结算进账" Then
    
79.             sum5 = sum5 + arr(i, 6): End If
    
80.     Next:
    
81.     wa.Range("F4").Value = sum
    
82.     wa.Range("F5").Value = sum2
    
83.     wa.Range("F6").Value = sum3
    
84.     wa.Range("F7").Value = sum4
    
85.     wa.Range("F8").Value = sum5
    
86.     '5月汇总
    
87.     sum = 0: sum2 = 0: sum3 = 0: sum4 = 0: sum5 = 0
    
88.     For i = 2 To 2401
    
89.         If Month(arr(i, 3)) = wa.Range("G2") And arr(i, 4) = wa.Range("B4") And arr(i, 5) = "结算进账" Then
    
90.             sum = sum + arr(i, 6): End If
    
91.         If Month(arr(i, 3)) = wa.Range("G2") And arr(i, 4) = wa.Range("B5") And arr(i, 5) = "结算进账" Then
    
92.             sum2 = sum2 + arr(i, 6): End If
    
93.         If Month(arr(i, 3)) = wa.Range("G2") And arr(i, 4) = wa.Range("B6") And arr(i, 5) = "结算进账" Then
    
94.             sum3 = sum3 + arr(i, 6): End If
    
95.         If Month(arr(i, 3)) = wa.Range("G2") And arr(i, 4) = wa.Range("B7") And arr(i, 5) = "结算进账" Then
    
96.             sum4 = sum4 + arr(i, 6): End If
    
97.         If Month(arr(i, 3)) = wa.Range("G2") And arr(i, 4) = wa.Range("B8") And arr(i, 5) = "结算进账" Then
    
98.             sum5 = sum5 + arr(i, 6): End If
    
99.     Next:
    
100.     wa.Range("G4").Value = sum
     
101.     wa.Range("G5").Value = sum2
     
102.     wa.Range("G6").Value = sum3
     
103.     wa.Range("G7").Value = sum4
     
104.     wa.Range("G8").Value = sum5
     
105.     '6月汇总
     
106.     sum = 0: sum2 = 0: sum3 = 0: sum4 = 0: sum5 = 0
     
107.     For i = 2 To 2401
     
108.         If Month(arr(i, 3)) = wa.Range("H2") And arr(i, 4) = wa.Range("B4") And arr(i, 5) = "结算进账" Then
     
109.             sum = sum + arr(i, 6): End If
     
110.         If Month(arr(i, 3)) = wa.Range("H2") And arr(i, 4) = wa.Range("B5") And arr(i, 5) = "结算进账" Then
     
111.             sum2 = sum2 + arr(i, 6): End If
     
112.         If Month(arr(i, 3)) = wa.Range("H2") And arr(i, 4) = wa.Range("B6") And arr(i, 5) = "结算进账" Then
     
113.             sum3 = sum3 + arr(i, 6): End If
     
114.         If Month(arr(i, 3)) = wa.Range("H2") And arr(i, 4) = wa.Range("B7") And arr(i, 5) = "结算进账" Then
     
115.             sum4 = sum4 + arr(i, 6): End If
     
116.         If Month(arr(i, 3)) = wa.Range("H2") And arr(i, 4) = wa.Range("B8") And arr(i, 5) = "结算进账" Then
     
117.             sum5 = sum5 + arr(i, 6): End If
     
118.     Next:
     
119.     wa.Range("H4").Value = sum
     
120.     wa.Range("H5").Value = sum2
     
121.     wa.Range("H6").Value = sum3
     
122.     wa.Range("H7").Value = sum4
     
123.     wa.Range("H8").Value = sum5
     
124.     '7月汇总
     
125.     sum = 0: sum2 = 0: sum3 = 0: sum4 = 0: sum5 = 0
     
126.     For i = 2 To 2401
     
127.         If Month(arr(i, 3)) = wa.Range("I2") And arr(i, 4) = wa.Range("B4") And arr(i, 5) = "结算进账" Then
     
128.             sum = sum + arr(i, 6): End If
     
129.         If Month(arr(i, 3)) = wa.Range("I2") And arr(i, 4) = wa.Range("B5") And arr(i, 5) = "结算进账" Then
     
130.             sum2 = sum2 + arr(i, 6): End If
     
131.         If Month(arr(i, 3)) = wa.Range("I2") And arr(i, 4) = wa.Range("B6") And arr(i, 5) = "结算进账" Then
     
132.             sum3 = sum3 + arr(i, 6): End If
     
133.         If Month(arr(i, 3)) = wa.Range("I2") And arr(i, 4) = wa.Range("B7") And arr(i, 5) = "结算进账" Then
     
134.             sum4 = sum4 + arr(i, 6): End If
     
135.         If Month(arr(i, 3)) = wa.Range("I2") And arr(i, 4) = wa.Range("B8") And arr(i, 5) = "结算进账" Then
     
136.             sum5 = sum5 + arr(i, 6): End If
     
137.     Next:
     
138.     wa.Range("I4").Value = sum
     
139.     wa.Range("I5").Value = sum2
     
140.     wa.Range("I6").Value = sum3
     
141.     wa.Range("I7").Value = sum4
     
142.     wa.Range("I8").Value = sum5
     
143.     '8月汇总
     
144.     sum = 0: sum2 = 0: sum3 = 0: sum4 = 0: sum5 = 0
     
145.     For i = 2 To 2401
     
146.         If Month(arr(i, 3)) = wa.Range("J2") And arr(i, 4) = wa.Range("B4") And arr(i, 5) = "结算进账" Then
     
147.             sum = sum + arr(i, 6): End If
     
148.         If Month(arr(i, 3)) = wa.Range("J2") And arr(i, 4) = wa.Range("B5") And arr(i, 5) = "结算进账" Then
     
149.             sum2 = sum2 + arr(i, 6): End If
     
150.         If Month(arr(i, 3)) = wa.Range("J2") And arr(i, 4) = wa.Range("B6") And arr(i, 5) = "结算进账" Then
     
151.             sum3 = sum3 + arr(i, 6): End If
     
152.         If Month(arr(i, 3)) = wa.Range("J2") And arr(i, 4) = wa.Range("B7") And arr(i, 5) = "结算进账" Then
     
153.             sum4 = sum4 + arr(i, 6): End If
     
154.         If Month(arr(i, 3)) = wa.Range("J2") And arr(i, 4) = wa.Range("B8") And arr(i, 5) = "结算进账" Then
     
155.             sum5 = sum5 + arr(i, 6): End If
     
156.     Next:
     
157.     wa.Range("J4").Value = sum
     
158.     wa.Range("J5").Value = sum2
     
159.     wa.Range("J6").Value = sum3
     
160.     wa.Range("J7").Value = sum4
     
161.     wa.Range("J8").Value = sum5
     
162.     '后面还有4个月的，发不出来了 高手给看看
     
163. End Sub
     
164. 
     

复制代码

shiruiqiang

建议字典处理汇总

liulang0808

Sub 按钮47_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("月流水库").UsedRange
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    For j = 2 To UBound(arr)
        m = Month(arr(j, 3))
        d(m & arr(j, 4)) = d(m & arr(j, 4)) + arr(j, 6)
        d(m & arr(j, 5)) = d(m & arr(j, 5)) + arr(j, 6)
    Next j
    For j = 3 To Cells(Rows.Count, 2).End(3).Row
        For i = 3 To 14
            If Len(Cells(j, 2)) > 0 Then
                k = Cells(2, i) & Cells(j, 2)
                If d.exists(k) Then
                    Cells(j, i) = d(k)
                End If
            End If
        Next
    Next j
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub

liulang0808

案例1.zip (55.32 KB, 下载次数: 26)

2024-3-15 07:47 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

用字典+数组，速度会快很多，代码会少很多。

1. Sub ykcbf()   '//2024.3.15
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("月流水库")
   
6.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
7.         arr = .[a1].Resize(r, 6)
   
8.     End With
   
9.     On Error Resume Next
   
10.     For j = 4 To 5
    
11.         For i = 2 To UBound(arr)
    
12.             If arr(i, 3) <> Empty Then
    
13.                 s = arr(i, j) & "|" & Month(arr(i, 3))
    
14.                 d(s) = d(s) + arr(i, 6)
    
15.             End If
    
16.         Next
    
17.     Next
    
18.     With Sheets("账目统计")
    
19.         r = .Cells(.Rows.Count, "b").End(xlUp).Row
    
20.         For i = 4 To r
    
21.             For j = 3 To 14
    
22.                 If .Cells(i, 2) <> Empty Then
    
23.                     s = .Cells(i, 2) & "|" & .Cells(2, j)
    
24.                     If d.Exists(s) Then
    
25.                         .Cells(i, j) = d(s)
    
26.                     End If
    
27.                 End If
    
28.             Next
    
29.         Next
    
30.     End With
    
31.     Set d = Nothing
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK！"
    
34. End Sub
    
35. 
    

复制代码

fzxba

1. Sub test0()
   
2.   
   
3.   Dim data, results, Dict As Object
   
4.   Dim i As Long, j As Long
   
5.   Dim posRow As Long, posCol As Long
   
6.   
   
7.   Set Dict = CreateObject("Scripting.Dictionary")
   
8.   
   
9.   Worksheets("账目统计").Activate
   
10.   With Range("B2")
    
11.     With Range(.End(xlToRight), .End(xlDown))
    
12.       Intersect(.Offset(0, 0), .Offset(1, 1)).ClearContents
    
13.       results = .Value
    
14.     End With
    
15.   End With
    
16.   
    
17.   For i = 3 To UBound(results)
    
18.     If Len(results(i, 1)) Then Dict.Add results(i, 1), i
    
19.   Next
    
20.   
    
21.   data = Worksheets("月流水库").Range("A1").CurrentRegion.Value
    
22.   For i = 2 To UBound(data)
    
23.     If Dict.Exists(data(i, 4)) Then
    
24.       posRow = Dict(data(i, 4))
    
25.       posCol = Month(data(i, 3)) + 1
    
26.       results(posRow, posCol) = results(posRow, posCol) + Val(data(i, 6))
    
27.       results(posRow, UBound(results, 2)) = results(posRow, UBound(results, 2)) + Val(data(i, 6))
    
28.       results(2, posCol) = results(2, posCol) + Val(data(i, 6))
    
29.       results(2, UBound(results, 2)) = results(2, UBound(results, 2)) + Val(data(i, 6))
    
30.     End If
    
31.   Next
    
32. 
    
33.   Range("B2").Resize(UBound(results), UBound(results, 2)).Value = results
    
34.   
    
35.   Set Dict = Nothing
    
36.   Beep
    
37. End Sub

复制代码

cnmlgb9998

用PQ实现，能即时更新，做了动态链接，你明细项目变化 也不怕。

jany1312

liulang0808 发表于 2024-3-15 07:46
Sub 按钮47_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("月流水库").U ...

我也学过VBA，自学的，对这个字典还有什么空间思维，我就是学不会看不懂

lkqsmxw

公式法，用到了辅助列和公式SUMIFS