20180830xlVBA_合并计算

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

　　

转载于:https://www.cnblogs.com/nextseven/p/9562420.html