多表汇总求和问题

lcjy11185

侠圣都说好，好好研究

lcjy11185

Sub qh()
    Dim d, arr, brr, sh As Worksheet, i&, n&, j%
    Set d = CreateObject("scripting.dictionary")
    ReDim brr(1 To 6553, 1 To 5)
    For Each sh In Worksheets
        If sh.Name <> "汇总" Then
            With sh
                arr = .[a1].CurrentRegion
                For i = 2 To UBound(arr)
                    If Not d.exists(arr(i, 1)) Then '初始字典，即第一次遇见
                        n = n + 1   '递增
                        d(arr(i, 1)) = n    '
                        For j = 1 To UBound(arr, 2) '
                            brr(n, j) = arr(i, j)   '
                        Next
                    Else    '第二次遇见
                        For j = 3 To UBound(arr, 2) '
                           brr(d(arr(i, 1)), j) = brr(d(arr(i, 1)), j) + arr(i, j)  'arr的第3到5列相加，赋值给brr,brr的行用字典的项目代替。
                        Next
                    End If
                Next
            End With
        End If
    Next
    [h1:l1] = [a1:e1].Value
    [h2].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

lysunsb

谢谢大家帮助，我还没搞好。重新传个附件

lcjy11185

lysunsb 发表于 2012-8-10 11:59
谢谢大家帮助，我还没搞好。重新传个附件

Sub qh()
     Dim d, arr, brr, sh As Worksheet, i&, n&, j%
     Application.ScreenUpdating = False
     Set d = CreateObject("scripting.dictionary")
     ReDim brr(1 To 6553, 1 To 16)
     For Each sh In Worksheets
         If sh.Name <> "汇总" Then
             With sh
                 arr = .[a1].CurrentRegion
                 For i = 2 To UBound(arr)
                     If Not d.exists(arr(i, 1)) Then '初始字典，即第一次遇见
                         n = n + 1   '递增
                         d(arr(i, 1)) = n    '
                         For j = 1 To UBound(arr, 2) '
                             brr(n, j) = arr(i, j)   '
                         Next
                     Else    '第二次遇见
                         For j = 2 To UBound(arr, 2) '
                            brr(d(arr(i, 1)), j) = brr(d(arr(i, 1)), j) + arr(i, j)  'arr的第2到15列相加，赋值给brr,brr的行用字典的项目代替。
                         Next
                     End If
                 Next
             End With
         End If
     Next
     Sheet9.[a1].CurrentRegion.Offset(1).ClearContents
     [a2].Resize(UBound(brr), UBound(brr, 2)) = brr
     Erase arr, brr
     Set d = Nothing
     Application.ScreenUpdating = True
End Sub

lcjy11185

test.rar (16.11 KB, 下载次数: 159)

2012-8-10 12:17 上传

点击文件名下载附件

lysunsb

lcjy11185 发表于 2012-8-10 12:17

太强了。谢谢

hsdongli

学习了 好代码

mjzxlmg

[a2].Resize(UBound(brr), UBound(brr, 2)) = brr
改为：[a2].Resize(n, UBound(brr, 2)) = brr

lcjy11185

对，更简单            

罗达

1. 查询语句：SELECT * FROM [1月$] UNION ALL SELECT * FROM [2月$]

复制代码

格式一致的汇总很方便：合并计算、透视表、函数公式、vba代码都行的，我推荐透视表。