VBA 实现工作簿汇总

转自 http://club.excelhome.net/thread-831194-1-4.html  蓝桥玄霜

有三个工作簿分别是A-01，B-01，C-01，还有一张工作薄是汇总-01
这四个工作簿有相同名字的工作表分别是产品1统计、产品2统计、产品3统计
我是想在工作簿汇总-01中的各个项目体现A-01\B-01\C-01的数量和。
因为A-01\B-01\C-01的文件不是固定的，所以我希望对于求和的工作簿是可选的，既根据使用者选择的工作簿进行自动求和

Public Arr1(), r%, strTmp$, nm$
Function GetFileFolderList(ObjFolder) As String
    Dim SubFolders, SubFolder, hz$
    Dim Files, File
    hz = "xls"  '指定后缀
    Set Files = ObjFolder.Files
    If Files.Count <> 0 Then
        For Each File In Files
            If InStr(File, hz) Then
                r = r + 1
                ReDim Preserve Arr1(1 To r)
                Arr1(r) = File
            End If
        Next
    End If
    Set SubFolders = ObjFolder.SubFolders
    If SubFolders.Count <> 0 Then
        For Each SubFolder In SubFolders
            strTmp = GetFileFolderList(SubFolder)
        Next
    End If
    GetFileFolderList = strTmp
End Function

Sub yy()
    Dim fso, folder, myPath$, Filename$, wb1 As Workbook, m&, Arr
    Dim Sht1 As Worksheet, i&, nm1$, wbnm$, sh As Worksheet, j&, y&
    Application.ScreenUpdating = False
    r = 0
    myPath = ThisWorkbook.Path & "\"
    Set wb1 = ThisWorkbook
    a = InStr(wb1.Name, ".")
    wbnm = Left(wb1.Name, a - 1)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(myPath)
    strTmp = GetFileFolderList(folder)
    For i = 1 To r
        Filename = Arr1(i)
        nm1 = Split(Mid(Filename, InStrRev(Filename, "\") + 1), ".")(0)
        If InStr(nm1, wbnm) Or Left(nm1, 1) = "{1}quot; Then GoTo 200
        xw = MsgBox("这个工作簿要汇总吗？", vbYesNo, "选择")
        If xw <> vbYes Then GoTo 200
        Workbooks.Open Filename
        Dim wb As Workbook
        Set wb = ActiveWorkbook
        For Each sh In wb.Sheets
            nm = sh.Name
            Arr = sh.[a1].CurrentRegion
            With wb1.Sheets(nm)
                For j = 2 To UBound(Arr)
                    For y = 2 To UBound(Arr, 2)
                        .Cells(j, y) = .Cells(j, y) + Arr(j, y)
                    Next
                Next
            End With
        Next
        wb.Close savechanges:=False
        Set wb = Nothing
200:
    Next
    Application.ScreenUpdating = True
End Sub