'23，多工作簿汇总（Do While+字典）

'http://club.excelhome.net/viewthread.php?tid=740844&pid=5036586&page=2&extra='预算 _

对比.xls

Sub hz()

    Dim Sht As Worksheet,col%, k1, t1

    Dim i&, Myr&,j&, ii&, Arr, r%, Arr1(), Brr

    Dim d, k, t

    Dim wb As Workbook, nm$

    Dim sh As Worksheet

    Dim PATH As String

    Dim dirr

    Set d =CreateObject("Scripting.Dictionary")

    bt = Array("实际数", "预算数", "实际与预算对比", "超支说明", _

    "是否有提交申请报告（超支流程流水号）")

    nm = "经营分析表汇总"

    PATH = ThisWorkbook.PATH

    dirr = Dir(PATH &"/*.xls")

    Do While dirr <>""

       If dirr <> ThisWorkbook.Name Then

           With GetObject(PATH & "\" & dirr)

               Set wb = Workbooks(dirr)

               Set sh = wb.Sheets(nm)

               For Each Sht In wb.Sheets

                   If InStr(Sht.Name, "店") Then

                       r = r + 1

                       ReDim Preserve Arr1(1 To r)

                       Arr1(r) = Sht.Name

                       Myr = Sht.[b65536].End(xlUp).Row - 1

                       Arr = Sht.Range("a4:c" & Myr)

                       For i = 1 To UBound(Arr)

                           If Arr(i, 2) <> "" Then

                               d(Arr(i, 2)) = ""

                           End If

                       Next

                   End If

               Next

               k = d.keys

               t = d.items

               ReDim Brr(1 To d.Count, 1 To 5 * r)

               d.RemoveAll

               For Each Sht In wb.Sheets

                   If InStr(Sht.Name, "店") Then col = col + 1

                       Myr = Sht.[b65536].End(xlUp).Row

                       Arr = Sht.Range("a4:f" & Myr)

                       For i = 1 To UBound(Arr)

                           If Arr(i, 2) <> "" Then

                               d(Arr(i, 2)) = Arr(i, 3) & "|" & Arr(i, 5) & "|"& Arr(i, 6)

                           End If

                       Next

                       k1 = d.keys

                       t1 = d.items

                       d.RemoveAll

                       For j = 0 To UBound(k1)

                           For ii = 0 To UBound(k)

                               If k1(j) = k(ii) Then

                                   Brr(ii + 1, 5 * col - 4) = Split(t1(j), "|")(0)

                                   Brr(ii + 1, 5 * col - 3) = Split(t1(j), "|")(1)

                                   Brr(ii + 1, 5 * col - 2) = Split(t1(j), "|")(2): Exit For

                               End If

                           Next

                       Next

                   End If

               Next

               wb.Close False

           End With

       End If

       dirr = Dir

    Loop

   [a4:iv1000].ClearContents

   [a4:iv1000].Borders.LineStyle = xlNone

    [b2:iv3].ClearContents

    [a4].Resize(UBound(k) +1, 1) = Application.Transpose(k)

    For i = 1 To r

       Cells(2, 5 * i - 3) = Arr1(i)

       Cells(2, 5 * i - 3).Resize(1, 5).Merge

       Cells(3, 5 * i - 3).Resize(1, 5) = bt

    Next

    [b4].Resize(UBound(Brr),5 * r) = Brr

    [a4].Resize(UBound(Brr),5 * r + 1).Borders.LineStyle = 1

End Sub

'http://club.excelhome.net/viewthread.php?_

tid=750050&pid=5094852&page=1&extra=page%3D1

Sub zdgx()

    Dim Arr, myPath$,myName$, sh As Worksheet

    Dim m&, funm$,n&, Sht As Worksheet

    Dim d, k, t, Brr

    Set d =CreateObject("Scripting.Dictionary")

   Application.ScreenUpdating = False

    funm = "汇总表.xls"

    Set Sht = ActiveSheet

   Sht.[a2:c1000].ClearContents

   Sht.[a2:c1000].Borders.LineStyle = xlNone

    myPath =ThisWorkbook.PATH & "\"

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

    n = 2

    Do While myName <>"" And myName <> funm

       With GetObject(myPath & myName)

           Set sh = .Sheets("Sheet1")

           m = sh.[a65536].End(xlUp).Row

           Arr = sh.Range("a2:c" & m)

           For i = 1 To UBound(Arr)

               x = Arr(i, 1) & "|" & Arr(i, 2)

               d(x) = d(x) + Arr(i, 3)

            Next

           .Close False

       End With

       myName = Dir

    Loop

    k = d.keys

    t = d.items

    ReDim Brr(1 To d.Count,1 To 3)

    For i = 0 To UBound(k)

       Brr(i + 1, 1) = Split(k(i), "|")(0)

       Brr(i + 1, 2) = Split(k(i), "|")(1)

       Brr(i + 1, 3) = t(i)

    Next

   Sht.Range("a2").Resize(d.Count, 3) = Brr

   Sht.Range("a1:c" & d.Count + 1).Borders.LineStyle = 1

    Set d = Nothing

   Application.ScreenUpdating = True

End Sub