如何在汇总表中汇总各月明细表中的动态商品名称？

FIFAWORLDCUP

1.工作表名称：2020年总数量，2020年总贷款，及每年的12个月的明细表分别为1月明细到12月明细。

2.工作表格式：1月明细到12月明细表格式统一，随着月份的推进增加当月明细工作表。每月明细表的表头从第二行开始，列举出每个商品名称，商品名称占据了同行的三个单元格并且已经合并在一起了，这种商品名称对应下一行的三个单元格分别是件数，数量和贷款。

各月的明细表的第二行B2单元格开始列举的是商品名称，每个明细工作表中的商品名称及数目不一定相同，且每个明细工作表中的商品名称及相应数据可能有增添，能否使代码在2020年总数量和2020年总贷款这两个工作表的第二行从B2单元格开始汇总当前所有明细工作表中的商品名称，每个单元格写一个商品名称，当明细工作表中的商品有增加时，每按一次代码运行按钮能够自动在2020年总数量和2020年总贷款这两个工作表的第二行的商品名称行中自动汇总添加或者删减，总之，每次汇总的商品为当前所有明细表中商品名称，重复的商品名称只显示一个。

进货表.rar (153.49 KB, 下载次数: 15)

2020-9-27 20:11 上传

点击文件名下载附件

蓝桥玄霜

表头的例子：

FIFAWORLDCUP

Option Explicit

Sub tqbt()
Dim Arr, i&
Dim d, k
Dim Sht As Worksheet
Set d = CreateObject("scripting.dictionary")
Sheet2.Activate
For Each Sht In Sheets
    If InStr(Sht.name, "明细") Then
        Arr = Sht.[a1].CurrentRegion
        For i = 2 To UBound(Arr, 2) Step 3
            If Arr(2, i) <> "" Then d(Arr(2, i)) = ""
        Next
    End If
Next
k = d.keys
[b2].Resize(1, 500).ClearContents
[b2].Resize(1, d.Count) = k
Sheet3.[b2].Resize(1, 500).ClearContents
Sheet3.[b2].Resize(1, d.Count) = k
End Sub

FIFAWORLDCUP

蓝桥玄霜 发表于 2020-9-27 21:37
表头的例子：

谢谢蓝版的帮助！

wxxydl

Sub lqxs()
    Dim arr, i&, j&
    Dim d, k, yy
    Dim sht As Worksheet
    Set d = CreateObject("scripting.dictionary")
    Sheet2.Activate
    For Each sht In Sheets
        If InStr(sht.name, "明细") Then
            yy = Left(sht.name, Len(sht.name) - 2)
            arr = sht.[a1].CurrentRegion
            For i = 2 To UBound(arr, 2) Step 3
                If arr(2, i) <> "" Then
                    If Not d.exists(arr(2, i)) Then
                        Set d(arr(2, i)) = CreateObject("scripting.dictionary")
                    End If
                    For j = 4 To 34
                        If arr(j, i + 1) <> "" Then
                            d(arr(2, i))(yy) = d(arr(2, i))(yy) + arr(j, i + 1)
                        End If
                    Next
                End If
            Next
        End If
    Next
    [b2].Resize(13, 500).ClearContents
    [b2].Resize(1, d.Count) = k
    arr = Sheet2.UsedRange
    For j = 2 To UBound(arr, 2)
        For i = 3 To 14
            If d.exists(arr(2, j)) Then
                If d(arr(2, j)).exists(arr(i, 1)) Then
                    arr(i, j) = d(arr(2, j))(arr(i, 1))
                End If
            End If
        Next
    Next
    Sheet2.[b1].Resize(12, d.Count) = arr
    Sheet3.[b2].Resize(1, 500).ClearContents
    Sheet3.[b2].Resize(1, d.Count) = k
End Sub

wxxydl

在蓝版完成第一表的填表

wxxydl

Sub lqxs()
    Dim arr, i&, j&
    Dim d, k, yy
    Dim sht As Worksheet
    Set d = CreateObject("scripting.dictionary")
    Sheet2.Activate
    For Each sht In Sheets
        If InStr(sht.name, "明细") Then
            yy = Left(sht.name, Len(sht.name) - 2)
            arr = sht.[a1].CurrentRegion
            For i = 2 To UBound(arr, 2) Step 3
                If arr(2, i) <> "" Then
                    If Not d.exists(arr(2, i)) Then
                        Set d(arr(2, i)) = CreateObject("scripting.dictionary")
                    End If
                    For j = 4 To 34
                        If arr(j, i + 1) <> "" Then
                            d(arr(2, i))(yy) = d(arr(2, i))(yy) + arr(j, i + 1)
                        End If
                    Next
                End If
            Next
        End If
    Next
    [b2].Resize(13, 500).ClearContents
    [b2].Resize(1, d.Count) = k
    arr = Sheet2.UsedRange
    For j = 2 To UBound(arr, 2)
        For i = 3 To 14
            If d.exists(arr(2, j)) Then
                If d(arr(2, j)).exists(arr(i, 1)) Then
                    arr(i, j) = d(arr(2, j))(arr(i, 1))
                End If
            End If
        Next
    Next
    Sheet2.[b1].Resize(12, d.Count) = arr
    Sheet3.[b2].Resize(1, 500).ClearContents
    Sheet3.[b2].Resize(1, d.Count) = k
End Sub