Sub WorkbooksSheetsConsolidate()
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
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
'更新求和数据
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
