Macro to Consolidate Data from Different Workbooks into One Workbook

JHCali

New Member
Joined
Dec 10, 2008
Messages
29
Greetings,

I need a macro that gathers information from 5 different workbooks and consolidates it on one tab in a 6th workbook.

For each file, the number of columns is the same, but the number of rows differs. What I need to macro to do is to take the data + column headings from the first of the 5 source files and paste them into the destination file. Then, for each subsequent source file, I need the macro to paste just the data (no column headings) starting in the row immediately below.

Also, this group of 6 files (5 source, 1 destination) will all be in one folder. However, I will be creating new folders on a weekly basis, so I would preferably need the macro to work without me having to go in every week and changing the file path. So below are just examples of names for people to help me with the code, and I can go in and change the details afterward.

Here are the details:

1) Each source file has the data I need to copy in columns A:G.
2) In each source file, the column headings are in row 1, with the data beginning in row 2.
3) In each source file, the data that I need to copy is in the "Data Output" tab.
4) The 5 source files are titled "Source1.xls" to "Source 5.xls"
5) In the destination file, the data will be copied and pasted into the "Data Consolidation" tab.
6) The destination file is titled "Destination.xls"
7) The file path where all the files are located is: "C:\Desktop\Week 1". Each wee I will create a new folder and update the number after the "Week".

I hope this is enough hypothetical information to enable you all to help me with the code.

Thank you all very much in advance.

Regards,

JHCali
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Hopefully I understood your request, there are still a few assumptions being made in my code. Such as the Destination file is always new in each week (but the code can be copied and pasted into the new workbook each week) and that the source data has no row breaks (no empty cells at least in column A) between the header and end of all entries. This code needs to be placed in the Data Consolidation tab of the Destination.xls file.

Code:
Sub CollectData()
' This code assumes it is running in the Destination.xls file's "Data Consolidation" tab.
' ---------------------------------------------------------------------------------------------
  Dim i As Long, lCurrRow As Long, lRow As Long, n As Long
  Dim wb As Workbook, ans As VbMsgBoxResult
   
  For i = 1 To 5 Step 1
    
    ' -----------------------------------------------------------------------------------------
    ' Open up Source Workbook
    ' -----------------------------------------------------------------------------------------
    On Error Resume Next
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\Source" & i & ".xls")
    If Not Err.Number = 0 Then
      Err.Clear
      
      ' ---------------------------------------------------------------------------------------
      ' Source Workbook was not found using SourceX.xls format, try Source X.xls format
      ' ---------------------------------------------------------------------------------------
      Set wb = Workbooks.Open(ThisWorkbook.Path & "\Source " & i & ".xls")
      If Not Err.Number = 0 Then
        Err.Clear
        
        ' -------------------------------------------------------------------------------------
        ' No source workbook found, advise user.
        ' -------------------------------------------------------------------------------------
        ans = MsgBox("Could not find Source " & i & " Workbook." & vbNewLine & "Do you wis" & _
                     "h to continue?", vbInformation + vbYesNo, "Error")
        If ans = vbNo Then Exit Sub
        GoTo NextI
      End If
    End If
    
    ' -----------------------------------------------------------------------------------------
    ' Source book was found, data to use is on Data Output.
    ' -----------------------------------------------------------------------------------------
    With wb.Sheets("Data Output")
      If Not Err.Number = 0 Then
        Err.Clear
        
        ' -------------------------------------------------------------------------------------
        ' No Data Output tab found, advise user.
        ' -------------------------------------------------------------------------------------
        ans = MsgBox("Could not find Source " & i & " Workbook's 'Data Output' tab." & _
                     vbNewLine & "Do you wish to continue?", vbInformation + vbYesNo, "Error")
        If ans = vbNo Then
          wb.Close False
          Exit Sub
        End If
        GoTo NextI
      End If
      
      ' ---------------------------------------------------------------------------------------
      ' Ensure we add headers.
      ' ---------------------------------------------------------------------------------------
      If i = 1 Then
        lRow = 1
      Else
        lRow = 2
      End If
      
      ' ---------------------------------------------------------------------------------------
      ' We are assuming the value in column A will be filled and there is no breaks until the
      ' end of our entries.  If this is not the case additional code will be needed to
      ' determine the end of our entries.
      ' ---------------------------------------------------------------------------------------
      Do Until .Range("A" & lRow).Value = vbNullString
        lCurrRow = lCurrRow + 1
        For n = 0 To 6 Step 1
          Me.Range("A" & lCurrRow).Offset(ColumnOffset:=n).Value = .Range("A" & lRow).Offset(ColumnOffset:=n).Value
        Next n
        lRow = lRow + 1
      Loop
    End With
NextI:
    wb.Close False
  Next i
  Set wb = Nothing
End Sub

Please note that I have not tested this code, please make a backup of your files before running!

I hope that helps!
 
Upvote 0
Hi Rosen,
This is almost perfect for my needs!!

There are three differences, and I've tried, but I can't figure out how to tweak the code to make it work ...

1) SOURCE WORKBOOK NAME FORMAT
I have three source workbooks called Pipeline ABC.xls, Pipeline DEF.xls and Pipeline GHI.xls. The macro above works only when I change the names to Pipeline1.xls, Pipeline2.xls and Pipeline3.xls. Unfortunately, these are established workbooks so I can't change the name format.

2) SOURCE WORKBOOKS PASSWORD PROTECTED
Each of the source workbooks is password protected, and each has a different password.

3) COLUMN HEADERS
I don't want to copy/paste the column headers from any source workbooks, just the data.

If you can help me with the code modifications I would be so grateful!!
 
Last edited:
Upvote 0
Try something like this...

I have added to custom functions to get your workbook names and passwords and removed what should now be a useless redundency in the workbook opening phase of the code.
Code:
Sub CollectData()
' This code assumes it is running in the Destination.xls file's "Data Consolidation" tab.
' ---------------------------------------------------------------------------------------------
  Dim i As Long, lCurrRow As Long, lRow As Long, n As Long
  Dim wb As Workbook, ans As VbMsgBoxResult
   
  For i = 1 To 3 Step 1
    
    ' -----------------------------------------------------------------------------------------
    ' Open up Source Workbook
    ' -----------------------------------------------------------------------------------------
    On Error Resume Next
    Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & GetSourceNameByIndex(i) & _
                            ".xls", Password:=GetPasswordByIndex(i))
    If Not Err.Number = 0 Then
      Err.Clear
              
      ' ---------------------------------------------------------------------------------------
      ' No source workbook found, advise user.
      ' ---------------------------------------------------------------------------------------
      ans = MsgBox("Could not find Source " & GetSourceNameByIndex(i) & " Workbook." & _
                   vbNewLine & "Do you wish to continue?", vbInformation + vbYesNo, "Error")
      If ans = vbNo Then Exit Sub
      GoTo NextI
    End If
    
    ' -----------------------------------------------------------------------------------------
    ' Source book was found, data to use is on Data Output.
    ' -----------------------------------------------------------------------------------------
    With wb.Sheets("Data Output")
      If Not Err.Number = 0 Then
        Err.Clear
        
        ' -------------------------------------------------------------------------------------
        ' No Data Output tab found, advise user.
        ' -------------------------------------------------------------------------------------
        ans = MsgBox("Could not find Source " & GetSourceNameByIndex(i) & " Workbook's 'Da" & _
                     "ta Output' tab." & vbNewLine & "Do you wish to continue?", _
                     vbInformation + vbYesNo, "Error")
        If ans = vbNo Then
          wb.Close False
          Exit Sub
        End If
        GoTo NextI
      End If
      
      ' ---------------------------------------------------------------------------------------
      ' Ensure we skip any headers. (set this value to the first row after the headers)
      ' ---------------------------------------------------------------------------------------
      lRow = 2
      
      ' ---------------------------------------------------------------------------------------
      ' We are assuming the value in column A will be filled and there is no breaks until the
      ' end of our entries.  If this is not the case additional code will be needed to
      ' determine the end of our entries.
      ' ---------------------------------------------------------------------------------------
      Do Until .Range("A" & lRow).Value = vbNullString
        lCurrRow = lCurrRow + 1
        For n = 0 To 6 Step 1
          Me.Range("A" & lCurrRow).Offset(ColumnOffset:=n).Value = .Range("A" & lRow).Offset(ColumnOffset:=n).Value
        Next n
        lRow = lRow + 1
      Loop
    End With
NextI:
    wb.Close False
  Next i
  Set wb = Nothing
End Sub

Function GetSourceNameByIndex(ByVal Index As Long) As String
  Select Case Index
    Case 1: GetSourceNameByIndex = "Pipeline ABC"
    Case 2: GetSourceNameByIndex = "Pipeline DEF"
    Case 3: GetSourceNameByIndex = "Pipeline GHI"
  End Select
End Function

Function GetPasswordByIndex(ByVal Index As Long) As String
  Select Case Index
    Case 1: GetPasswordByIndex = "Pipeline ABC Password"
    Case 2: GetPasswordByIndex = "Pipeline DEF Password"
    Case 3: GetPasswordByIndex = "Pipeline GHI Password"
  End Select
End Function
Hope that helps!
 
Upvote 0
Hi Rosen - it's working beautifully, except for one thing ... the data from the source workbooks is pasting over the header column (in row 1) in the master workbook.

Below is the code, modified for my workbooks.

Also, I didn't know how to change the section: "No Data Output Tab Found, Advise User" (in my case, the "Data Output" tab is called "CIVIL")

Thank you so much for your help!!!!

Sub CollectData()
' This code assumes it is running in the Workbook_Master.xls file's "CIVIL" tab.
' ---------------------------------------------------------------------------------------------
Dim i As Long, lCurrRow As Long, lRow As Long, n As Long
Dim wb As Workbook, ans As VbMsgBoxResult

For i = 1 To 3 Step 1

' -----------------------------------------------------------------------------------------
' Open up Source Workbook
' -----------------------------------------------------------------------------------------
On Error Resume Next
Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & GetSourceNameByIndex(i) & _
".xls", Password:=GetPasswordByIndex(i))
If Not Err.Number = 0 Then
Err.Clear

' ---------------------------------------------------------------------------------------
' No source workbook found, advise user.
' ---------------------------------------------------------------------------------------
ans = MsgBox("Could not find Source " & GetSourceNameByIndex(i) & " Workbook." & _
vbNewLine & "Do you wish to continue?", vbInformation + vbYesNo, "Error")
If ans = vbNo Then Exit Sub
GoTo NextI
End If

' -----------------------------------------------------------------------------------------
' Source book was found, data to use is on CIVIL.
' -----------------------------------------------------------------------------------------
With wb.Sheets("CIVIL")
If Not Err.Number = 0 Then
Err.Clear

' -------------------------------------------------------------------------------------
' No CIVIL tab found, advise user.
' -------------------------------------------------------------------------------------
ans = MsgBox("Could not find Source " & GetSourceNameByIndex(i) & " Workbook's 'Da" & _
"ta Output' tab." & vbNewLine & "Do you wish to continue?", _
vbInformation + vbYesNo, "Error")
If ans = vbNo Then
wb.Close False
Exit Sub
End If
GoTo NextI
End If

' ---------------------------------------------------------------------------------------
' Ensure we skip any headers. (set this value to the first row after the headers)
' ---------------------------------------------------------------------------------------
lRow = 2

' ---------------------------------------------------------------------------------------
' We are assuming the value in column A will be filled and there is no breaks until the
' end of our entries. If this is not the case additional code will be needed to
' determine the end of our entries.
' ---------------------------------------------------------------------------------------
Do Until .Range("A" & lRow).Value = vbNullString
lCurrRow = lCurrRow + 1
For n = 0 To 21 Step 1
Me.Range("A" & lCurrRow).Offset(ColumnOffset:=n).Value = .Range("A" & lRow).Offset(ColumnOffset:=n).Value
Next n
lRow = lRow + 1
Loop
End With
NextI:
wb.Close False
Next i
Set wb = Nothing
End Sub


Function GetSourceNameByIndex(ByVal Index As Long) As String
Select Case Index
Case 1: GetSourceNameByIndex = "CDN Pipeline"
Case 2: GetSourceNameByIndex = "GMJ Pipeline"
Case 3: GetSourceNameByIndex = "PSF Pipeline"
End Select
End Function


Function GetPasswordByIndex(ByVal Index As Long) As String
Select Case Index
Case 1: GetPasswordByIndex = "cdn"
Case 2: GetPasswordByIndex = "mj"
Case 3: GetPasswordByIndex = "pf"
End Select
End Function
 
Upvote 0
The error message was written on multiple lines (I have a thing for code not exceeding 96 characters across so I can print it and not have the system control the wrapping; its somewhat OCDish and not always condusive to reading the code.) I have fixed in the code below as well as insure we skip the first line of the 'CIVIL' worksheet.
Code:
Sub CollectData()
' This code assumes it is running in the Workbook_Master.xls file's "CIVIL" tab.
' ---------------------------------------------------------------------------------------------
Dim i As Long, lCurrRow As Long, lRow As Long, n As Long
Dim wb As Workbook, ans As VbMsgBoxResult
For i = 1 To 3 Step 1
' -----------------------------------------------------------------------------------------
' Open up Source Workbook
' -----------------------------------------------------------------------------------------
On Error Resume Next
Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & GetSourceNameByIndex(i) & _
".xls", Password:=GetPasswordByIndex(i))
If Not Err.Number = 0 Then
Err.Clear
' ---------------------------------------------------------------------------------------
' No source workbook found, advise user.
' ---------------------------------------------------------------------------------------
ans = MsgBox("Could not find Source " & GetSourceNameByIndex(i) & " Workbook." & _
vbNewLine & "Do you wish to continue?", vbInformation + vbYesNo, "Error")
If ans = vbNo Then Exit Sub
GoTo NextI
End If
' -----------------------------------------------------------------------------------------
' Source book was found, data to use is on CIVIL.
' -----------------------------------------------------------------------------------------
With wb.Sheets("CIVIL")
If Not Err.Number = 0 Then
Err.Clear
' -------------------------------------------------------------------------------------
' No CIVIL tab found, advise user.
' -------------------------------------------------------------------------------------
ans = MsgBox("Could not find Source " & GetSourceNameByIndex(i) & " Workbook's 'CI" & _
"VIL' tab." & vbNewLine & "Do you wish to continue?", _
vbInformation + vbYesNo, "Error")
If ans = vbNo Then
wb.Close False
Exit Sub
End If
GoTo NextI
End If
' ---------------------------------------------------------------------------------------
' Ensure we skip any headers. (set this value to the first row after the headers)
' ---------------------------------------------------------------------------------------
lRow = 2

' ---------------------------------------------------------------------------------------
' We are assuming the value in column A will be filled and there is no breaks until the
' end of our entries. If this is not the case additional code will be needed to
' determine the end of our entries.
' ---------------------------------------------------------------------------------------
Do Until .Range("A" & lRow).Value = vbNullString
lCurrRow = lCurrRow + 1
If lCurrRow = 1 Then lCurrRow = 2 ' insure we don't overwrite the CIVIL headers
For n = 0 To 21 Step 1
Me.Range("A" & lCurrRow).Offset(ColumnOffset:=n).Value = .Range("A" & lRow).Offset(ColumnOffset:=n).Value
Next n
lRow = lRow + 1
Loop
End With
NextI:
wb.Close False
Next i
Set wb = Nothing
End Sub

Function GetSourceNameByIndex(ByVal Index As Long) As String
Select Case Index
Case 1: GetSourceNameByIndex = "CDN Pipeline"
Case 2: GetSourceNameByIndex = "GMJ Pipeline"
Case 3: GetSourceNameByIndex = "PSF Pipeline"
End Select
End Function

Function GetPasswordByIndex(ByVal Index As Long) As String
Select Case Index
Case 1: GetPasswordByIndex = "cdn"
Case 2: GetPasswordByIndex = "mj"
Case 3: GetPasswordByIndex = "pf"
End Select
End Function
I hope that helps!
 
Upvote 0
Hi Rosen,
I spoke too soon, sorry! It worked great on my test workbooks, but when applied to my real ones it worked - but super duper slowly. It took approx 5 minutes for each worksheet to open then close, so approx 15 minutes in total.

Each "real" source workbook has 5 sheets (two have the data, the three others are various summaries for that person's data).
And the "real" master workbook 8 sheets (again, two sheets for data and the rest are summaries/reports)

Also each source workbook has its own macros for multiple advance filters, many saved in "This Workbook" and another bunch saved in "Personal."

Another thing: while the column range for the data is A-V for one of the sheets, and A-W for the other ... I have the advanced filter criteria on columns beyond that (but hidden) so the column range is actually quite long

Lastly: there are formulas in almost every columns (A-V) that goes from row 1 to row 1000, but no actual values until a selection is made from a drop-down menu in column A.

With the data currently in it, each source workbook is 1.10 MB

Do I have too many things going on here? Does something stand out to you as a big problem (or everything)? Any ideas/tips/thoughts are much appreciated.
 
Upvote 0
Do you mind running it again, this time with an added time log? I would like to know at what point in the code we are having the slow down.
Code:
Sub CollectData()
' This code assumes it is running in the Workbook_Master.xls file's "CIVIL" tab.
' ---------------------------------------------------------------------------------------------
Dim i As Long, lCurrRow As Long, lRow As Long, n As Long
Dim wb As Workbook, ans As VbMsgBoxResult
For i = 1 To 3 Step 1
' ---------------------------------------------------------------------------------------------
' Open up Source Workbook
' ---------------------------------------------------------------------------------------------
On Error Resume Next
WriteTimeStampedEntry "Starting to open file " & GetSourceNameByIndex(i)
Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & GetSourceNameByIndex(i) & _
".xls", Password:=GetPasswordByIndex(i))
If Not Err.Number = 0 Then
Err.Clear
' ---------------------------------------------------------------------------------------------
' No source workbook found, advise user.
' ---------------------------------------------------------------------------------------------
ans = MsgBox("Could not find Source " & GetSourceNameByIndex(i) & " Workbook." & _
vbNewLine & "Do you wish to continue?", vbInformation + vbYesNo, "Error")
WriteTimeStampedEntry "Error occured opening " & GetSourceNameByIndex(i)
If ans = vbNo Then Exit Sub
GoTo NextI
End If
WriteTimeStampedEntry "Finished opening " & GetSourceNameByIndex(i)
' ---------------------------------------------------------------------------------------------
' Source book was found, data to use is on CIVIL.
' ---------------------------------------------------------------------------------------------
With wb.Sheets("CIVIL")
If Not Err.Number = 0 Then
Err.Clear
' ---------------------------------------------------------------------------------------------
' No CIVIL tab found, advise user.
' ---------------------------------------------------------------------------------------------
ans = MsgBox("Could not find Source " & GetSourceNameByIndex(i) & " Workbook's 'CI" & _
"VIL' tab." & vbNewLine & "Do you wish to continue?", _
vbInformation + vbYesNo, "Error")
If ans = vbNo Then
wb.Close False
Exit Sub
End If
GoTo NextI
End If
' ---------------------------------------------------------------------------------------
' Ensure we skip any headers. (set this value to the first row after the headers)
' ---------------------------------------------------------------------------------------
lRow = 2
' ---------------------------------------------------------------------------------------
' We are assuming the value in column A will be filled and there is no breaks until the
' end of our entries. If this is not the case additional code will be needed to
' determine the end of our entries.
' ---------------------------------------------------------------------------------------
WriteTimeStampedEntry "Starting data collection for " & GetSourceNameByIndex(i)
Do Until .Range("A" & lRow).Value = vbNullString
lCurrRow = lCurrRow + 1
If lCurrRow = 1 Then lCurrRow = 2 ' insure we don't overwrite the CIVIL headers
For n = 0 To 21 Step 1
Me.Range("A" & lCurrRow).Offset(ColumnOffset:=n).Value = .Range("A" & lRow).Offset(ColumnOffset:=n).Value
Next n
lRow = lRow + 1
Loop
WriteTimeStampedEntry "Finished data collection for " & GetSourceNameByIndex(i)
End With
NextI:
wb.Close False
WriteTimeStampedEntry "Closed out " & GetSourceNameByIndex(i)
Next i
Set wb = Nothing
End Sub

Function GetSourceNameByIndex(ByVal Index As Long) As String
Select Case Index
Case 1: GetSourceNameByIndex = "CDN Pipeline"
Case 2: GetSourceNameByIndex = "GMJ Pipeline"
Case 3: GetSourceNameByIndex = "PSF Pipeline"
End Select
End Function

Function GetPasswordByIndex(ByVal Index As Long) As String
Select Case Index
Case 1: GetPasswordByIndex = "cdn"
Case 2: GetPasswordByIndex = "mj"
Case 3: GetPasswordByIndex = "pf"
End Select
End Function

Sub WriteTimeStampedEntry(ByVal msg As String)
Dim oFileSystem
Dim oTextStream
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
Set oTextStream = oFileSystem.OpenTextFile(ThisWorkbook.Path & "\CollectData.log", 8, True)
oTextStream.WriteLine Now() & ": " & msg
oTextStream.Close
Set oTextStream = Nothing
Set oFileSystem = Nothing
End Sub
This should give us an idea where to start looking.
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,287
Members
448,562
Latest member
Flashbond

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