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

'2012-11-1

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

Sub Macro1()

    Dim myPath$, myName$, dAs 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