使用字典和数组配合进行月报表汇总

两个月报表格，每个表格是按照类别产品名称、发货类型以及发货时间分类的的发货数量表，其中货品名称有重复，需要累加汇总至模板格式的大报表中。如下图：

1.png 2.png 3.png

VBA解决方案代码如下：

Sub 报表()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim d1 As Object
    Dim d2 As Object
    Set d1 = CreateObject("scripting.dictionary")
    Dim arr, brr, crr(1 To 12, 1 To 62), drr, err, kk, tt
    Dim lrow As Long, lcol As Long, lrow2 As Long
    Dim m As Integer, n As Integer
    Dim sht As Worksheet
    For Each sht In Worksheets
        If sht.Name <> "LCM" And sht.Name <> "ITC" And sht.Name <> "模板" Then
            sht.Delete
        End If
    Next
    With Sheets("LCM")
        lrow = .Cells(Rows.Count, 3).End(3).Row
        lcol = .Cells(2, Columns.Count).End(1).Column
        For i = 3 To lrow Step 12
            If Not d1.exists(.Range("a" & i).Value) Then
                arr = .Range("d" & i & ":AH" & i + 11)
                For m = 1 To 12
                    For n = 1 To lcol - 3
                        crr(m, n * 2 - 1) = arr(m, n)
                    Next
                Next
                d1(.Range("a" & i).Value) = crr
            Else
                brr = .Range("d" & i & ":AH" & i + 11)
                err = d1(.Range("a" & i).Value)
                For m = 1 To 12
                    For n = 1 To lcol - 3
                        err(m, n * 2 - 1) = err(m, n * 2 - 1) + brr(m, n)
                    Next
                Next
                d1(.Range("a" & i).Value) = err
            End If
        Next
    End With
    With Sheets("ITC")
        lrow2 = .Cells(Rows.Count, 3).End(3).Row
        For i = 3 To lrow2 Step 12
            If Not d1.exists(.Range("a" & i).Value) Then
                arr = .Range("d" & i & ":AH" & i + 11)
                Erase crr '重要，否则将把表一中的数据代入
                For m = 1 To 12
                    For n = 1 To lcol - 3
                        crr(m, n * 2) = arr(m, n)
                    Next
                Next
                d1(.Range("a" & i).Value) = crr
            Else
                brr = .Range("d" & i & ":AH" & i + 11)
                drr = d1(.Range("a" & i).Value)
                 For m = 1 To 12
                    For n = 1 To lcol - 3
                        drr(m, n * 2) = drr(m, n * 2) + brr(m, n)
                    Next
                Next
                d1(.Range("a" & i).Value) = drr
            End If
        Next
    End With
    kk = d1.items
    tt = d1.keys
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    ActiveWindow.Zoom = 90 '页面显示比例为90%
    ActiveSheet.Cells.Clear
    For i = 1 To d1.Count
        Sheets("模板").Rows("2:18").Copy ActiveSheet.Rows(i * 18 - 16)
    Next
    For i = 0 To d1.Count - 1
        ActiveSheet.Range("b" & i * 18 + 5) = tt(i)
        ActiveSheet.Range("e" & (i * 18 + 5)).Resize(12, 62) = kk(i)
    Next
    ActiveSheet.Columns(2).ColumnWidth = 14 '设置B列列宽为14pt
    Application.ScreenUpdating = False
    Application.DisplayAlerts = True
End Sub

最终效果如下：

4.png