一个复杂的多表汇总问题（表头会变动），请高人指点？

如何用VBA实现附件中的明细数据 汇总到汇总表里？ 请各位高人看看

问题:
想对月数据进行汇总(同项目 同姓名的就相加）
说明:
1.明细表的个数不确定
2.明细表的 项目都在第2行(从A3开始) 和 姓名 都在第一列(从B2开始)
3.明细表的项目 和 姓名 是可以变化的(这里只是列举了3个月的数据）
(汇总时,黄色区域根据明细表的变化  包含了明细表中的所有对应内容的最大集合--剔除重复，现在的样子就是一个例子)

请测试
Sub Macro1()
    Dim arr, brr(), sh As Worksheet, i&, j&, m&, n&, d As Object, ds As Object
    Set d = CreateObject("scripting.dictionary")
    Set ds = CreateObject("scripting.dictionary")
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            arr = sh.[a1].CurrentRegion
            For j = 2 To UBound(arr, 2)
                If Not d.Exists(arr(2, j)) Then
                    n = n + 1
                    d(arr(2, j)) = n
                End If
            Next
        End If
    Next
    ReDim brr(1 To 60000, n)
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            arr = sh.[a1].CurrentRegion
            For i = 3 To UBound(arr)
                If Not ds.Exists(arr(i, 1)) Then
                    m = m + 1
                    ds(arr(i, 1)) = m
                    brr(m, 0) = arr(i, 1)
                    For j = 2 To UBound(arr, 2)
                        brr(m, d(arr(2, j))) = arr(i, j)
                    Next
                Else
                    For j = 2 To UBound(arr, 2)
                        brr(ds(arr(i, 1)), d(arr(2, j))) = brr(ds(arr(i, 1)), d(arr(2, j))) + arr(i, j)
                    Next
                End If
            Next
        End If
    Next
    ActiveSheet.UsedRange.Offset(2).ClearContents
    Range("B2:iv2").ClearContents
    [b2].Resize(, n) = d.Keys
    [a3].Resize(m, n + 1) = brr
    Application.ScreenUpdating = True
End Sub

附件
wt.rar (30.36 KB)

see if help you

纯简单公式弄的  如不喜欢  请勿理会

参考附件。