'31，多工作簿汇总(vbDirectory)

'2012-9-23

'http://club.excelhome.net/forum.php?mod=viewthread&tid=924305&page=1#pid6330929

Sub ts()

    Dim myPath$, subPath$,shcount&, wb As Object

    Dim subPaths() As Byte,br()

    Dim i&, j&,k&, t!

    t = Timer

   Application.ScreenUpdating = False

    myPath =ThisWorkbook.PATH & "\绩效管理\"

    subPath = Dir(myPath,vbDirectory)

    Do While subPath<> ""

       If subPath <> "." And subPath <> ".." Then

           k = k + 1

           ReDim Preserve subPaths(1 To k)

           subPaths(k) = Val(Replace(subPath, "月份", ""))

       End If

       subPath = Dir

    Loop

    For i = 1 ToUBound(subPaths) - 1

       For j = i + 1 To UBound(subPaths)

           If subPaths(i) > subPaths(j) Then

               Temp = subPaths(i): subPaths(i) = subPaths(j): subPaths(j) = Temp

           End If

       Next j

    Next i

    For i = 1 ToUBound(subPaths)

        myPath1= myPath & subPaths(i) & "月份\"

       myfile = Dir(myPath1 & "*.xls*")

       Do While myfile <> ""

           Set wb = GetObject(myPath1 & myfile)

           With wb

               For j = 1 To .Sheets.Count

                   ar = .Sheets(j).[a3].Resize(.Sheets(j).Cells(Rows.Count, 1).End(3).Row - 2, 13)

                   ReDim Preserve br(1 To 13, 1 To UBound(ar) + myRows)

                   For m = myRows + 1 To UBound(ar) + myRows

                       For n = 1 To 13

                           br(n,m) = ar(m - myRows, n)

                       Next n

                   Next m

                   myRows = myRows + UBound(ar)

               Next j

               .Close False

           End With

           myfile = Dir

        Loop

    Next i

   Sheet2.[A2:M65536].ClearContents

   Sheet2.[a2].Resize(UBound(br, 2), UBound(br)) = Application.Transpose(br)

   Application.ScreenUpdating = True

    MsgBox "数据汇总完成!用时: " & Format(Timer -t, "0.00s")

End Sub