Sub WorkbooksConsolidate()

    Rem 设置求和区域为 sheet名称/单元格区域;sheet名称/单元格区域

    Const Setting As String = "Sheet1/A1:G6;Sheet1/A8:E8;Sheet1/F8:G8;Sheet2/A1:G3;Sheet2/A5:G5"

    Const FOLDER_NAME As String = "文件夹"

    Dim StartTime As Variant

    Dim UsedTime As Variant

    StartTime = VBA.Timer

    AppSettings True

    Dim Wb As Workbook

    Dim Sht As Worksheet

    Dim Dic As Object

    Dim Key As String

    Dim OneKey

    Dim Brr

    Dim Arr As Variant

    Dim Rng As Range

    Dim FilePaths, FilePath

    Dim FolderPath As String

    Dim OpenWb As Workbook

    Dim OpenSht As Worksheet

    Set Dic = CreateObject("Scripting.Dictionary")

    Set Wb = Application.ThisWorkbook

    FolderPath = Wb.Path & "\" & FOLDER_NAME & "\"

    Dim SheetName, RngAddress

    Dim Areas, OneArea

    Areas = Split(Setting, ";")

    For Each OneArea In Areas

        SheetName = Split(OneArea, "/")(0)

        RngAddress = Split(OneArea, "/")(1)

        '解析地址 初始化数组

        On Error Resume Next

        Set Sht = Wb.Worksheets(SheetName)

        If Err.Number = 9 Then

            MsgBox "当前工作簿不存在名为【" & SheetName & "】的工作簿!", vbInformation, "Information"

            GoTo ErrorExit

        End If

        On Error GoTo 0

        Set Rng = Sht.Range(RngAddress)

        Rng.ClearContents

        Arr = Rng.Value

        Debug.Print SheetName; "   "; RngAddress

        Do

            If Dic.Exists(SheetName) = False Then Exit Do

            SheetName = SheetName & "@"

        Loop

        Dic(SheetName) = Array(RngAddress, Arr)

    Next OneArea

    FilePaths = FsoGetFiles(FolderPath, "*.xls*")

    If FilePaths(1) = "None" Then

        MsgBox "指定文件夹未找到任何工作簿!", vbInformation, "Information"

        GoTo ErrorExit

    End If

    For Each FilePath In FilePaths

        Set OpenWb = Application.Workbooks.Open(FilePath)

        For Each OneKey In Dic.Keys

            SheetName = Replace(OneKey, "@", "")

            On Error Resume Next

            Set OpenSht = OpenWb.Worksheets(SheetName)

            If Err.Number = 9 Then

                MsgBox "打开工作簿不存在名为【" & SheetName & "】的工作簿!", vbInformation, "Information"

                OpenWb.Close False

                GoTo ErrorExit

            End If

            On Error GoTo 0

            Ar = Dic(OneKey)

            RngAddress = Ar(0)

            Arr = Ar(1)

            Set Rng = OpenSht.Range(RngAddress)

            Brr = Rng.Value

            If Rng.Cells.Count > 1 Then

                For i = LBound(Arr) To UBound(Arr)

                    For j = LBound(Arr, 2) To UBound(Arr, 2)

                        If IsNumeric(Brr(i, j)) Then

                            '只有为数字时才可以相加

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

                        Else

                            MsgBox "工作簿：" & FilePath & vbCr & _

                                "工作表：" & SheetName & vbCr & _

                                "单元格：" & Rng.Cells(i, j).Address & "的数据不是数字，不能累加"

                            GoTo ErrorExit

                        End If

                    Next j

                Next i

            Else

                If IsNumeric(Brr) Then

                    '只有为数字时才可以相加

                    Arr = Arr + Brr

                Else

                    MsgBox "工作簿：" & FilePath & vbCr & _

                        "工作表：" & SheetName & vbCr & _

                        "单元格：" & Rng.Cells(i, j).Address & "的数据不是数字，不能累加"

                    GoTo ErrorExit

                End If

            End If

            '更新求和数据

            Ar(1) = Arr

            Dic(OneKey) = Ar

        Next OneKey

        OpenWb.Close False

    Next FilePath

    For Each OneKey In Dic.Keys

        SheetName = Replace(OneKey, "@", "")

        Ar = Dic(OneKey)

        RngAddress = Ar(0)

        Arr = Ar(1)

        Set Sht = Wb.Worksheets(SheetName)

        Set Rng = Sht.Range(RngAddress)

        Rng.Value = Arr

    Next OneKey

    UsedTime = VBA.Timer - StartTime

    Debug.Print "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")

    'MsgBox "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")

ErrorExit:

    Set Dic = Nothing

    Set Wb = Nothing

    Set Sht = Nothing

    Set Rng = Nothing

    Set OpenWb = Nothing

    Set OpenSht = Nothing

    Erase Arr

    Erase Brr

    Erase Ar

    AppSettings False

End Sub

Function FsoGetFiles(ByVal FolderPath As String, ByVal Pattern As String, Optional ComplementPattern As String = "") As String()

    Dim Arr() As String

    Dim FSO As Object

    Dim ThisFolder As Object

    Dim OneFile As Object

    ReDim Arr(1 To 1)

    Arr(1) = "None"

    Dim Index As Long

    Index = 0

    Set FSO = CreateObject("Scripting.FileSystemObject")

    On Error GoTo ErrorExit

    Set ThisFolder = FSO.getfolder(FolderPath)

    If Err.Number <> 0 Then Exit Function

    For Each OneFile In ThisFolder.Files

        If OneFile.Name Like Pattern Then

            If Len(ComplementPattern) > 0 Then

                If Not OneFile.Name Like ComplementPattern Then

                    Index = Index + 1

                    ReDim Preserve Arr(1 To Index)

                    Arr(Index) = OneFile.Path

                End If

            Else

                Index = Index + 1

                ReDim Preserve Arr(1 To Index)

                Arr(Index) = OneFile.Path

            End If

        End If

    Next OneFile

ErrorExit:

    FsoGetFiles = Arr

    Erase Arr

    Set FSO = Nothing

    Set ThisFolder = Nothing

    Set OneFile = Nothing

End Function

Sub AppSettings(Optional IsStart As Boolean = True)

    Application.ScreenUpdating = IIf(IsStart, False, True)

    Application.DisplayAlerts = IIf(IsStart, False, True)

    Application.Calculation = IIf(IsStart, xlCalculationManual, xlCalculationAutomatic)

    Application.StatusBar = IIf(IsStart, ">>>>>>>>Macro Is Running>>>>>>>>", False)

End Sub