汇总同一工作簿的其他工作表

hcy1185

汇总同一工作簿的其他工作表，代码现在把所有工作表都汇总了，想分年度汇总在”汇总表“，请老师帮助，谢谢！！

龙凤煤矿2022年-2024年销售汇总表.rar (24.27 KB, 下载次数: 15)

2024-12-17 09:52 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim ws As Worksheet
   
5.     Dim d As Object
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     Set d1 = CreateObject("scripting.dictionary")
   
10.     n = 3
    
11.     For Each ws In Worksheets
    
12.         If Right(ws.Name, 1) = "年" Then
    
13.             d1(ws.Name) = n
    
14.             n = n + 3
    
15.         End If
    
16.     Next
    
17.     ls = 2 + d1.Count * 3
    
18.     For Each ws In Worksheets
    
19.         If Right(ws.Name, 1) = "年" Then
    
20.             n = d1(ws.Name)
    
21.             With ws
    
22.                 r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
23.                 arr = .Range("a3:e" & r)
    
24.                 For i = 1 To UBound(arr)
    
25.                     If Not d.exists(arr(i, 2)) Then
    
26.                         ReDim brr(1 To ls)
    
27.                         brr(2) = arr(i, 2)
    
28.                     Else
    
29.                         brr = d(arr(i, 2))
    
30.                     End If
    
31.                     brr(n) = brr(n) + arr(i, 3)
    
32.                     brr(n + 2) = brr(n + 2) + arr(i, 5)
    
33.                     d(arr(i, 2)) = brr
    
34.                 Next
    
35.             End With
    
36.         End If
    
37.     Next
    
38.     ReDim crr(1 To d.Count, 1 To ls)
    
39.     ReDim drr(1 To ls)
    
40.     drr(2) = "合计"
    
41.     m = 0
    
42.     For Each aa In d.keys
    
43.         brr = d(aa)
    
44.         m = m + 1
    
45.         brr(1) = m
    
46.         For j = 1 To UBound(brr)
    
47.             crr(m, j) = brr(j)
    
48.         Next
    
49.         For j = 3 To UBound(brr)
    
50.             drr(j) = drr(j) + brr(j)
    
51.         Next
    
52.     Next
    
53.     For j = 3 To UBound(drr) Step 3
    
54.         If Len(drr(j)) <> 0 And drr(j) <> 0 Then
    
55.             drr(j + 1) = Application.Round(drr(j + 2) / drr(j), 2)
    
56.         End If
    
57.     Next
    
58.     With Worksheets("汇总表")
    
59.         .Cells.Clear
    
60.         With .Range("a1")
    
61.             .Value = "龙凤煤矿" & d1.keys()(0) & "--" & d1.keys()(d1.Count - 1) & "销售汇总表"
    
62.             .Resize(1, ls).Merge
    
63.             With .Font
    
64.                 .Name = "宋体"
    
65.                 .Size = 20
    
66.                 .Bold = True
    
67.             End With
    
68.         End With
    
69.         .Range("a2:b2") = Array("序号", "煤炭品种")
    
70.         For j = 1 To 2
    
71.             .Cells(2, j).Resize(2, 1).Merge
    
72.         Next
    
73.         n = 3
    
74.         For Each aa In d1.keys
    
75.             With .Cells(2, n)
    
76.                 .Value = aa & "销售汇总"
    
77.                 .Resize(1, 3).Merge
    
78.             End With
    
79.             .Cells(3, n).Resize(1, 3) = Array("销售数量" & vbLf & "(吨)", "销售单价" & vbLf & "(元/吨)", "销售金额" & vbLf & "(元)")
    
80.             n = n + 3
    
81.         Next
    
82.         With .Range("a4").Resize(1, UBound(drr))
    
83.             .Value = drr
    
84.             With .Font
    
85.                 .Bold = True
    
86.             End With
    
87.         End With
    
88.         .Range("a5").Resize(UBound(crr), UBound(crr, 2)) = crr
    
89.         With .Range("a2").Resize(2 + 1 + UBound(crr), UBound(crr, 2))
    
90.             .Borders.LineStyle = xlContinuous
    
91.             With .Font
    
92.                 .Name = "宋体"
    
93.                 .Size = 10
    
94.             End With
    
95.         End With
    
96.         With .UsedRange
    
97.             .HorizontalAlignment = xlCenter
    
98.             .VerticalAlignment = xlCenter
    
99.         End With
    
100.     End With
     
101. End Sub
     

复制代码

chxw68

参与一下。

hcy1185

chxw68 发表于 2024-12-17 10:24
参与一下。

先谢谢啦！每次都是麻烦您！！

chxw68

hcy1185 发表于 2024-12-17 10:28
先谢谢啦！每次都是麻烦您！！

统计表格表头是代码自动生成的，统计自适应年份增减。

hcy1185

chxw68 发表于 2024-12-17 10:24
参与一下。

全自动的，太好啦！要慢慢消化

chxw68

按B列排了序。

hcy1185

chxw68 发表于 2024-12-17 12:15
按B列排了序。

老师！单价就只有合计行有，能否有金额的都计算一下单价？谢谢！

chxw68

修改好了。