Merge data from multiple worksheets from numerous workbooks

B

bar21967

New Member
Joined
May 16, 2011
Messages
8
Office Version
  1. 365
Platform
  1. Windows
With the following code I open workbooks located in a specified directory, copy and paste add ranges from the open workbook to a single destination workbook.

For example, each workbook contains several sheet beginning with "New Init" and each sheets data should be added/summarized/merged into a worksheet by the same name in the destination workbook. Six workbooks containing the worksheet "New Init- Parts" copies several ranges and pastes them into a Consolidation workbook with New Init- Parts worksheet.

There are eight worksheets beginning with the same name and the same layout.

Unfortunately it takes several minutes to run because it's so poorly designed.

Any help would be appreciated.

Code: 
Sub Consolidate()
'
    Dim intRow As Integer
    Dim strFile As String, strPath As String
    Dim wsDest As Worksheet, wbSource As Workbook
    Dim rngSalesRegions As Range, rngArea As Range
'
    Form1.Hide
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.AskToUpdateLinks = False
'
    Set wsDest = ActiveSheet
    strPath = InputBox("Identify the path to consolidate.", "Consolidation Path", "s:\accounting\oesch\strategicplan\")
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
    intRow = Range("STARTFILENAMES").Row
'
' Instruction filename list
    Sheets("Instructions").Select
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Range("filenames").ClearContents
    Set rngSalesRegions = wsDest.Range("filenames")
    Do Until strFile = ""
'
        ' List files included in consolidation
        Cells(intRow, 2) = strFile
        intRow = intRow + 1
        strFile = Dir()
    Loop
    wsDest.Range("A1").Select
'
' Consolidate New Init- LCCS
'
    Sheets("New Initiatives- LCCS").Select
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Set rngSalesRegions = wsDest.Range("E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47")
    rngSalesRegions.ClearContents
    Do Until strFile = ""
'
        Set wbSource = Workbooks.Open(strPath & strFile)
'
        For Each rngArea In rngSalesRegions.Areas
 
            ' Consolidate for each sales region
            wbSource.Sheets("New Initiatives- LCCS").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
'
' Consolidate New Init- Other Cost
'
    Sheets("New Init- Other Cost").Select
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Set rngSalesRegions = wsDest.Range("E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47")
    rngSalesRegions.ClearContents
    Do Until strFile = ""
'
        Set wbSource = Workbooks.Open(strPath & strFile)
'
        For Each rngArea In rngSalesRegions.Areas
 
            ' Consolidate for each sales region
            wbSource.Sheets("New Init- Other Cost").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
'
' Consolidate New Init- Geo Exp
'
    Sheets("New Init- Geo Exp").Select
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Set rngSalesRegions = wsDest.Range("E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47")
    rngSalesRegions.ClearContents
    Do Until strFile = ""
        Set wbSource = Workbooks.Open(strPath & strFile)
'
        For Each rngArea In rngSalesRegions.Areas
 
            ' Consolidate for each sales region
            wbSource.Sheets("New Init- Geo Exp").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
'
' Consolidate New Init- Product Exp
'
    Sheets("New Init- Product Exp").Select
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Set rngSalesRegions = wsDest.Range("E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47")
    rngSalesRegions.ClearContents
    Do Until strFile = ""
        Set wbSource = Workbooks.Open(strPath & strFile)
'
        For Each rngArea In rngSalesRegions.Areas
 
            ' Consolidate for each sales region
            wbSource.Sheets("New Init- Product Exp").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
'
'
' Consolidate New Init- Market Exp
'
    Sheets("New Init- Market Exp").Select
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Set rngSalesRegions = wsDest.Range("E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47")
    rngSalesRegions.ClearContents
    Do Until strFile = ""
        Set wbSource = Workbooks.Open(strPath & strFile)
'
        For Each rngArea In rngSalesRegions.Areas
 
            ' Consolidate for each sales region
            wbSource.Sheets("New Init- Market Exp").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
'
' Consolidate New Init- Facility Conso
'
    Sheets("New Init- Facility Conso").Select
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Set rngSalesRegions = wsDest.Range("E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47")
    rngSalesRegions.ClearContents
    Do Until strFile = ""
        Set wbSource = Workbooks.Open(strPath & strFile)
'
        For Each rngArea In rngSalesRegions.Areas
 
            ' Consolidate for each sales region
            wbSource.Sheets("New Init- Facility Conso").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
'
' Consolidate New Init- Parts
'
    Sheets("New Init- Parts").Select
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Set rngSalesRegions = wsDest.Range("E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47")
    rngSalesRegions.ClearContents
    Do Until strFile = ""
        Set wbSource = Workbooks.Open(strPath & strFile)
'
        For Each rngArea In rngSalesRegions.Areas
 
            ' Consolidate for each sales region
            wbSource.Sheets("New Init- Parts").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
'
' Consolidate New Init- Other
'
    Sheets("New Init- Other").Select
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Set rngSalesRegions = wsDest.Range("E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47")
    rngSalesRegions.ClearContents
    Do Until strFile = ""
        Set wbSource = Workbooks.Open(strPath & strFile)
'
        For Each rngArea In rngSalesRegions.Areas
 
            ' Consolidate for each sales region
            wbSource.Sheets("New Init- Other").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
'
'
' Consolidate Base
    Sheets("Base LOB Plan").Select
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Set rngSalesRegions = wsDest.Range("D11:P12,D18:P19,D23:P23,D27:P28,D29:P29,D33:P33,D42:P44,W17:AC17,W21:AC21,W25:AC25,W31:AC31,W35:AC35,W42:AC42")
    rngSalesRegions.ClearContents
    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
'
'
' Consolidate Total
    Sheets("Total LOB Plan").Select
'
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Set rngSalesRegions = wsDest.Range("D11:P12,D18:P19,D23:P23,D27:P29,D33:P33,D42:P44,W17:AC17,W21:AC21,W25:AC25,W31:AC31,W35:AC35,W42:AC42")
    rngSalesRegions.ClearContents
 
    Do Until strFile = ""
        Set wbSource = Workbooks.Open(strPath & strFile)
'
        For Each rngArea In rngSalesRegions.Areas
 
            ' Consolidate for each sales region
            wbSource.Sheets("Total 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
'
' Consolidate Economic Profit
'
    Sheets("Economic Profit").Select
'
    Set wsDest = ActiveSheet
    strFile = Dir(strPath & "strategic*.xls")
    wsDest.Unprotect
'
    Set rngSalesRegions = wsDest.Range("D28:D31,D56")
    rngSalesRegions.ClearContents
 
    Do Until strFile = ""
        Set wbSource = Workbooks.Open(strPath & strFile)
'
        For Each rngArea In rngSalesRegions.Areas
 
            ' Consolidate for each sales region
            wbSource.Sheets("Economic Profit").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.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.AskToUpdateLinks = True
    Calculate
'
    MsgBox "Consolidation Complete"
 
End Sub
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Sort by date Sort by votes
I've attempted a re-write without being able to test.
Hopefully I have included the necessary minutia.
TEST, TEST, TEST on a COPY.

Your original slowness largely comes from opening and closing the files 11 times more than necessary.

Another thing I saw was the use of this:
Code: 
    Sheets("Instructions").Select
    Set wsDest = ActiveSheet

Code: 
 Set wsDest = Sheets("Instructions")
will suffice without the programmatic load of the .Select (minute compared to the opening/closing load)

UNTESTED

Code: 
Sub ConsolidateByTweedle()
'
    Dim intRow As Integer
    Dim strFile As String, strPath As String
    Dim wsDest As Worksheet, SrcSht As Worksheet, wbSource As Workbook
    Dim rngSalesRegions As Range, rngArea As Range
'
    Form1.Hide
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.AskToUpdateLinks = False
'
'======================================================================================
'Clear the Dest WorkBook Ranges first
With ActiveWorkbook
    For Each Worksheet In .Worksheets
            Select Case SrcSht.Name
                Case Is = "New Initiatives- LCCS"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Other Cost"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Geo Exp"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Product Exp"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Market Exp"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Facility Conso"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Parts"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Other"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "Base LOB Plan"
                    SalesRegions$ = "D11:P12,D18:P19,D23:P23,D27:P28,D29:P29,D33:P33,D42:P44,W17:AC17,W21:AC21,W25:AC25,W31:AC31,W35:AC35,W42:AC42"
                Case Is = "Total LOB Plan"
                    SalesRegions$ = "D11:P12,D18:P19,D23:P23,D27:P29,D33:P33,D42:P44,W17:AC17,W21:AC21,W25:AC25,W31:AC31,W35:AC35,W42:AC42"
                Case Is = "Economic Profit"
                    SalesRegions$ = "D28:D31,D56"
                Case Else
                    GoTo SkipSheet1:
            End Select
            wsDest.Unprotect
            Set rngSalesRegions = wsDest.Range(SalesRegions$)
            rngSalesRegions.ClearContents
            wsDest.Protect
SkipSheet1:
    Next
End With
 
'Get user input
    strPath = InputBox("Identify the path to consolidate.", "Consolidation Path", "s:\accounting\oesch\strategicplan\")
    strFile = Dir(strPath & "strategic*.xls")
 
'Start Looping Files
    Do Until strFile = ""
 
    Set wbSource = Workbooks.Open(strPath & strFile)
'Loop Sheets in Each File
        For Each SrcSht In wbSource.Sheets
 
'Determine the SalesRegion Ranges
            Select Case SrcSht.Name
                Case Is = "New Initiatives- LCCS"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Other Cost"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Geo Exp"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Product Exp"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Market Exp"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Facility Conso"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Parts"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "New Init- Other"
                    SalesRegions$ = "E6:Q20,W19:AC19,W23:AC23,W29:AC29,W35:AC35,W41:AC41,W47:AC47"
                Case Is = "Base LOB Plan"
                    SalesRegions$ = "D11:P12,D18:P19,D23:P23,D27:P28,D29:P29,D33:P33,D42:P44,W17:AC17,W21:AC21,W25:AC25,W31:AC31,W35:AC35,W42:AC42"
                Case Is = "Total LOB Plan"
                    SalesRegions$ = "D11:P12,D18:P19,D23:P23,D27:P29,D33:P33,D42:P44,W17:AC17,W21:AC21,W25:AC25,W31:AC31,W35:AC35,W42:AC42"
                Case Is = "Economic Profit"
                    SalesRegions$ = "D28:D31,D56"
                Case Else
                    GoTo SkipSheet2:
            End Select
 
            'Match the Destination Sheet to the Source Sheet we have open
            Set wsDest = Sheets(SrcSht.Name)
            wsDest.Unprotect
            Set rngSalesRegions = wsDest.Range(SalesRegions$)
 
            'Do the Copy/Paste
               For Each rngArea In rngSalesRegions.Areas
                   ' Consolidate for each sales region
                   wbSource.Sheets(SrcSht.Name).Range(rngArea.Address).Copy
 
                   wsDest.Range("A1").Select
                   rngArea.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, _
                                        SkipBlanks:=True, Transpose:=False
               Next rngArea
               wsDest.Range("A1").Select
               wsDest.Protect
SkipSheet2: 'Skipping a sheet we don't recognize
    SalesRegions$ = ""
        Next SrcSht 'Moving onto next sheet
 
    'When through all sheets, Close, No Save
    wbSource.Close False
 
    'Get a New File
    strFile = Dir()
    Loop
'Wrap up and be done
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.AskToUpdateLinks = True
    Calculate
'
    MsgBox "Consolidation Complete"
End Sub
 
Upvote 0
Edits:

in the upper select statement:
Select Case SrcSht.Name
s/b
Select Case Worksheet.Name

'------------------------------------------------------------
Set wsDest = Worksheets(Worksheet.Name) ''Added
wsDest.Unprotect
Set rngSalesRegions = wsDest.Range(SalesRegions$)
rngSalesRegions.ClearContents
wsDest.Protect
SkipSheet1:
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question Question
Copy from multiple worksheets and multiple source files in a folder and paste into multiple sheets in target workbook
Replies
0
Views
630
Hs72711
H
A
  • Question Question
Automation of Copy and Merge Data in Column A and B of all files in a folder. Order of Data Differs
Replies
2
Views
712
ashish002
A
T
  • Question Question
Copying a range of data from multiple workbooks to a master
Replies
5
Views
658
TerenceTitus
T
J
  • Question Question
Copying a range from multiple workbooks to summary workbooks with corresponding worksheets
2
Replies
13
Views
2K
DanteAmor
DanteAmor
J
  • Question Question
Syntax error in my modified code. Trying to compile data from multiple workbooks into master workbook.
Replies
4
Views
554
j2mbs
J

Forum statistics

Threads
1,224,586
Messages
6,179,729
Members
452,939
Latest member
WCrawford

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top