20180831xlVBA_WorksheetsCosolidate

Sub WorkSheetsConsolidate()
    Rem 设置求和区域为 单元格区域;单元格区域
    Const Setting As String = "A1;B2:C4"
    Dim StartTime As Variant
    Dim UsedTime As Variant
    StartTime = VBA.Timer
    
    AppSettings True
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OneSht As Worksheet
    Const MAIN_SHEET As String = "1"
    Dim Dic As Object
    Dim Key As String
    Dim OneKey
    Dim Brr
    Dim Arr As Variant
    Dim Rng As Range
    Dim RngAddress
    Dim Areas, OneArea
    
    
    
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets(MAIN_SHEET)
    
    Areas = Split(Setting, ";")
    For Each OneArea In Areas
        RngAddress = OneArea
        Set Rng = Sht.Range(RngAddress)
        Rng.ClearContents
        Arr = Rng.Value
        Dic(RngAddress) = Arr
    Next OneArea
    
    For Each OneKey In Dic.Keys
        For Each OneSht In Wb.Worksheets
            If OneSht.Name <> Sht.Name Then
                Arr = Dic(OneKey)
                RngAddress = OneKey
                Set Rng = OneSht.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 "工作表：" & OneSht.Name & vbCr & _
                                    "单元格：" & Rng.Cells(i, j).Address & "的数据不是数字，不能累加"
                                GoTo ErrorExit
                            End If
                        Next j
                    Next i
                Else
                    Arr = Arr + Brr
                End If
                '更新求和数据
                Dic(OneKey) = Arr
            End If
        Next OneSht
    Next OneKey
    
    
    For Each OneKey In Dic.Keys
        RngAddress = OneKey
        Arr = Dic(OneKey)
        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

    AppSettings False
End Sub

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/9564624.html