32，多工作簿汇总，先赋值给数组

'32，多工作簿汇总，先赋值给数组

'2012-11-1

'http://club./forum.php?mod=viewthread&tid=556649&page=11#pid6432836

Sub Macro1()

    Dim myPath$, myName$, d As Object, Arr, Brr(1 To 60000, 1 To 22), i&, j&, m&, s$

    Application.ScreenUpdating = False

    Set d = CreateObject("scripting.dictionary")

    myPath = ThisWorkbook.PATH & "\分表\"

    myName = Dir(myPath & "*.xls")

    Do While myName <> ""

        With GetObject(myPath & myName)

            Arr = .Sheets(1).[a1].CurrentRegion

            For i = 2 To UBound(Arr)

                s = Arr(i, 1) & "," & Arr(i, 6) & "," & Arr(i, 10) & "," & Arr(i, 12)

                If Not d.exists(s) Then

                    d(s) = Arr(i, 14)

                    m = m + 1

                    For j = 1 To UBound(Arr, 2)

                        Brr(m, j) = Arr(i, j)

                    Next

                    Brr(m, 14) = d(s)

                Else

                    d(s) = d(s) + Arr(i, 14)

                    For j = 1 To m

                        s1 = Brr(j, 1) & "," & Brr(j, 6) & "," & Brr(j, 10) & "," & Brr(j, 12)

                        If s1 = s Then Brr(j, 14) = d(s): Exit For

                    Next

                End If

            Next

            .Close False

        End With

        myName = Dir

    Loop

    ActiveSheet.UsedRange.Offset(1).ClearContents [a2].Resize(m, 22) = Brr

    Application.ScreenUpdating = True

End Sub