Add multiple ranges from multiple workbooks

[bar21967]

I need to summarize or consolidate data from different worksheets from numerous workbooks into a summary file. For example, I need a total for each cell in range W17:AC17 from the "Base LOB Plan" worksheet in no less than four workbooks.

All the workbooks are located in c:\temp\ and the file names all begin with the word Strategic.

c:\temp\strategic plans packaging.xls
c:\temp\strategic plans coating.xls

How would I right a macro to summarize the data?

 

[AlphaFrog]

Sub Consolidate_Strategic_Plans()

    Dim strFile As String, strPath As String
    Dim wsDest As Worksheet, wbSource As Workbook
    
    Set wsDest = ActiveSheet
    strPath = "C:\Temp\"
    strFile = Dir(strPath & "strategic*.xls")
    
    Application.ScreenUpdating = False
    Do Until strFile = ""
    
        Set wbSource = Workbooks.Open(strPath & strFile)
        wbSource.Sheets("Base LOB Plan").Range("W17:AC17").Copy
        wsDest.Range("W17").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, _
                                         SkipBlanks:=True, Transpose:=False
        wbSource.Close SaveChanges:=False
        strFile = Dir()
    Loop
    Application.ScreenUpdating = True
    
    MsgBox "Consolidation Complete"
    
End Sub

 

[bar21967]

AlphaFrog,

That was extermely helpful!

I used your code and added loops for the other ranges on the same worksheet that I also needed to consolidate. However, I think I may have made the code more cumbersome than I needed to.

Keeping in mind I need to use the same macro for two more worksheets, how should I clean up the code?

Thanks in advance for your help!!! It is much appreciated.

Sub BaseSalesByGeo()
    Dim strFile As String, strPath As String
    Dim wsDest As Worksheet, wbSource As Workbook
 
    Application.ScreenUpdating = False
'
    Set wsDest = ActiveSheet
    strPath = "S:\Accounting\Oesch\StrategicPlan\"
    strFile = Dir(strPath & "strategic*.xls")
    ActiveSheet.Unprotect
'
    Range("W17:AC17,W21:AC21,W25:AC25,W31:AC31,W35:AC35,W42:AC42").Select
    Selection.ClearContents
 
' Consolidate USA Sales
    Do Until strFile = ""
 
        Set wbSource = Workbooks.Open(strPath & strFile)
        wbSource.Sheets("Base LOB Plan").Range("W17:AC17").Copy
        wsDest.Range("W17").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, _
                                         SkipBlanks:=True, Transpose:=False
        wbSource.Close SaveChanges:=False
        strFile = Dir()
    Loop
'
'   Consolidate Americas Sales
    Set wsDest = ActiveSheet
    strPath = "S:\Accounting\Oesch\StrategicPlan\"
    strFile = Dir(strPath & "strategic*.xls")
 
    Do Until strFile = ""
 
        Set wbSource = Workbooks.Open(strPath & strFile)
        wbSource.Sheets("Base LOB Plan").Range("W21:AC21").Copy
        wsDest.Range("W21").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, _
                                         SkipBlanks:=True, Transpose:=False
        wbSource.Close SaveChanges:=False
        strFile = Dir()
    Loop
'
'   Consolidate Europe Sales
    Set wsDest = ActiveSheet
    strPath = "S:\Accounting\Oesch\StrategicPlan\"
    strFile = Dir(strPath & "strategic*.xls")
 
    Do Until strFile = ""
 
        Set wbSource = Workbooks.Open(strPath & strFile)
        wbSource.Sheets("Base LOB Plan").Range("W25:AC25").Copy
        wsDest.Range("W25").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, _
                                         SkipBlanks:=True, Transpose:=False
        wbSource.Close SaveChanges:=False
        strFile = Dir()
    Loop
'
'   Consolidate Japan Sales
    Set wsDest = ActiveSheet
    strPath = "S:\Accounting\Oesch\StrategicPlan\"
    strFile = Dir(strPath & "strategic*.xls")
 
    Do Until strFile = ""
 
        Set wbSource = Workbooks.Open(strPath & strFile)
        wbSource.Sheets("Base LOB Plan").Range("W31:AC31").Copy
        wsDest.Range("W31").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, _
                                         SkipBlanks:=True, Transpose:=False
        wbSource.Close SaveChanges:=False
        strFile = Dir()
    Loop
'
'   Consolidate Asia Pacific Sales
    Set wsDest = ActiveSheet
    strPath = "S:\Accounting\Oesch\StrategicPlan\"
    strFile = Dir(strPath & "strategic*.xls")
 
    Do Until strFile = ""
 
        Set wbSource = Workbooks.Open(strPath & strFile)
        wbSource.Sheets("Base LOB Plan").Range("W35:AC35").Copy
        wsDest.Range("W35").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, _
                                         SkipBlanks:=True, Transpose:=False
        wbSource.Close SaveChanges:=False
        strFile = Dir()
    Loop
'
'   Consolidate China Sales
    Set wsDest = ActiveSheet
    strPath = "S:\Accounting\Oesch\StrategicPlan\"
    strFile = Dir(strPath & "strategic*.xls")
 
    Do Until strFile = ""
 
        Set wbSource = Workbooks.Open(strPath & strFile)
        wbSource.Sheets("Base LOB Plan").Range("W42:AC42").Copy
        wsDest.Range("W42").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, _
                                         SkipBlanks:=True, Transpose:=False
        wbSource.Close SaveChanges:=False
        strFile = Dir()
    Loop
'
    ActiveSheet.Protect
    Range("A1").Select
'
'    Application.ScreenUpdating = True
 
    MsgBox "Consolidation Complete"
 
End Sub

 

[AlphaFrog]

Sub BaseSalesByGeo()

    Dim strFile As String, strPath As String
    Dim wsDest As Worksheet, wbSource As Workbook
    Dim rngSalesRegions As Range, rngArea As Range
 
    Application.ScreenUpdating = False

    Set wsDest = ActiveSheet
    strPath = "S:\Accounting\Oesch\StrategicPlan\"
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect

    Set rngSalesRegions = wsDest.Range("W17:AC17,W21:AC21,W25:AC25,W31:AC31,W35:AC35,W42:AC42")
    rngSalesRegions.ClearContents
 
    ' Consolidate
    Do Until strFile = ""
 
        Set wbSource = Workbooks.Open(strPath & strFile)
        
        For Each rngArea In rngSalesRegions.Areas
        
            ' Consolidate for each sales region
            wbSource.Sheets("Base LOB Plan").Range(rngArea.Address).Copy
            rngArea.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, _
                                 SkipBlanks:=True, Transpose:=False
            
        Next rngArea
        
        wbSource.Close SaveChanges:=False
        strFile = Dir()
    Loop

    wsDest.Range("A1").Select
    wsDest.Protect
    Application.ScreenUpdating = True
 
    MsgBox "Consolidation Complete"
 
End Sub

 

[bar21967]

Perfect! You have been a huge help.
Thank you so much.