如何进行这种类型表格的分类汇总？

FIFAWORLDCUP

表格布局为同一个工作簿中多个月表，工作表标签名称为1月，2月到12月表格。格式如图所示：

有两个汇总表，一个为数量总表另一个为货款总表，格式如图所示：

汇总表的表头根据每个月表B列的品类汇总生成到汇总表的第二行。
每个月表中相同品类的商品有重复出现的情况。

每个品类的商品按月生成到总表对应的单元格。

谢谢！
进货表.rar (64.16 KB, 下载次数: 14)

2020-9-28 16:15 上传

点击文件名下载附件

FIFAWORLDCUP

在每个分表中的每个品类的数量和货款可以用字典求和，但要汇总到总表中要如何转移过来？

FIFAWORLDCUP

使用字典的方法汇总，怎么无法实现，代码要更改哪些地方？


Sub sums()
Dim m, n, k, j, y, arr, i
Dim sht As Worksheet
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
y = Sheet2.Cells(2, Columns.Count).End(xlToLeft).Column

For k = 3 To 14
m = Sheet2.Cells(k, 1)
   
    For Each sht In Sheets
    dc.RemoveAll
   
        If sht.Name = m Then
            arr = sht.[a1].CurrentRegion
            
            For i = 3 To UBound(arr) Step 1
                If Trim(arr(i, 2)) <> "" Then
                    dc(Trim(arr(i, 2))) = dc(Trim(arr(i, 2))) + arr(i, 6)
                End If
            Next i
            For n = 2 To y
            If dc.exists(Trim(sht.Cells(2, n))) Then
            sht.Cells(k, n) = dc(Trim(sht.Cells(2, n)))
            Else
            sht.Cells(k, n) = 0
            End If
            Next n
        End If
        
    Next sht

Next k

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr(1 To 2)
   
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.   n = 1
   
10.   For Each ws In Worksheets
    
11.     If ws.Name Like "*月" Then
    
12.       With ws
    
13.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
14.         arr = .Range("a3:h" & r)
    
15.         For i = 1 To UBound(arr)
    
16.           If Not d.exists(arr(i, 2)) Then
    
17.             n = n + 1
    
18.             d(arr(i, 2)) = n
    
19.           End If
    
20.         Next
    
21.       End With
    
22.     End If
    
23.   Next
    
24.   ReDim crr(1 To 12, 1 To d.Count + 1)
    
25.   For k = 1 To 2
    
26.     brr(k) = crr
    
27.   Next
    
28.   For Each ws In Worksheets
    
29.     If ws.Name Like "*月" Then
    
30.       m = Val(ws.Name)
    
31.       With ws
    
32.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
33.         arr = .Range("a3:h" & r)
    
34.         For i = 1 To UBound(arr)
    
35.           n = d(arr(i, 2))
    
36.           brr(1)(m, n) = brr(1)(m, n) + arr(i, 6)
    
37.           brr(2)(m, n) = brr(2)(m, n) + arr(i, 7)
    
38.         Next
    
39.       End With
    
40.     End If
    
41.   Next
    
42.   For k = 1 To 2
    
43.     With Worksheets(IIf(k = 1, "2020年总数量", "2020年总货款"))
    
44.       .Cells.Clear
    
45.       .Range("a2") = "月份"
    
46.       .Range("b2").Resize(1, d.Count) = d.keys
    
47.       .Range("a3").Resize(13, 1) = Application.Transpose(Array("1月", "2月", "3月", "4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月", "合计"))
    
48.       .Range("b3").Resize(UBound(brr(k)), UBound(brr(k), 2)) = brr(k)
    
49.       .Range("b15").Resize(1, UBound(brr(k), 2) - 1).FormulaR1C1 = "=SUM(R3C:R[-1]C)"
    
50.       With .Range("a2").Resize(UBound(brr(k)) + 2, UBound(brr(k), 2))
    
51.         .Borders.LineStyle = xlContinuous
    
52.         With .Font
    
53.           .Name = "微软雅黑"
    
54.           .Size = 11
    
55.         End With
    
56.       End With
    
57.       .Columns(1).Resize(, UBound(brr(k), 2)).AutoFit
    
58.         
    
59.       With .UsedRange
    
60.         .HorizontalAlignment = xlCenter
    
61.         .VerticalAlignment = xlCenter
    
62.       End With
    
63.     End With
    
64.   Next
    
65. End Sub
    

复制代码

chxw68

详见附件。

FIFAWORLDCUP

chxw68 发表于 2020-9-28 17:12
详见附件。

非常感谢褚老师的帮助！

运行的结果有两处存在这样的问题：

9月对应的数据跑到原本所在单元格的右侧去了。

chxw68

修改好了。

清风竹-

请看附件。

FIFAWORLDCUP

chxw68 发表于 2020-9-28 17:51
修改好了。

辛苦褚老师了！


还有一个小问题：如果两个汇总表的表头一致且包括了所有品类名称，并且事先输入固定下来。这个代码要改哪些地方？

谢谢！

chxw68

FIFAWORLDCUP 发表于 2020-9-28 18:51
辛苦褚老师了！

用字典记录列字段位置，读取分表数据时，先判断列字段是否在总表中，如果在的话，读出字典中保存的列位置，然后逐个写入数组。