Community Pick: Many members of our community have endorsed this article.
Editor's Choice: This article has been selected by our editors as an exceptional contribution.

Collating worksheets from one or more workbooks into a summary file

Dave
CERTIFIED EXPERT
Published:
Updated:

Introduction

One of the more common requests in the online VBA forums is for code that will collate data into a single workbook. This code provides three options:
1) Collate all sheets from all Excel workbooks in a single folder into a single summary worksheet
2) Collate all sheets from all Excel workbooks in a single folder into a single summary workbook
3) Collate all sheets from a single Excel workbook into a single summary worksheet

I will now walk through several of the main code sections to explain their purpose, the full code is presented in it's entirety at the end of this article.
 

Understanding the code

1) Code scope
The code uses a Boolean InputBox to get the user to specify whether the code is to be applied to either all Excel WorkBooks in a specific directory (the default TRUE option), or whether the user wants to process a single file (FALSE option).
If bProcessFolder Then
                          strFolderName = BrowseForFolder(strDefaultFolder)
                          'Look for xls, xlsx, xlsm files
                          strFileName = Dir(strFolderName & "\*.xls*")
                      Else
                          strFileName = Application _
                                        .GetOpenFilename("Select file to process (*.xls), *.xls")
                      End If

Open in new window



A second Boolean InputBox variable -  bNewSheet -  is used to store whether the code is to compile all the source worksheets into a single target worksheet (the default TRUE option), or whether each source worksheet should be copied to it's own target worksheet in the new workbook.

The code tests if the user wants to create an exact replica of a single file (FALSE for both Boolean Inputs) and exits if this is the case.

The directory option prompts the user to select a folder using the Shell object BrowseForFolder, whereas the single file option prompts the user to pick a particular file using GetOpenFileName.
 
If the user selected TRUE in step 1 then the code applies a  Do loop in combination with Dir to open all the *.xls* files in a specific directory for processing. The Dir approach is used as Microsoft has disabled the FileSearch method in xl2007, note that Dir does not provided an inbuilt sub folder option, so the code below would need to modified to call itself recursively if users wanted to apply the consolidation approach to all *.xls* files that sit in or under a specific directory.

The same code block is used to process a single file, if the user has selected this option then a Boolean variable is used to force the Do loop to exit after processing the file.

2) Managing the Excel environment
A single sheet workbook is created for the code output using a template.
Set Wb1 = Workbooks.Add(1)

Open in new window

The Application settings are then set to turn off screen updating and user alerts, to disable any automatic macros that may exist in the target file(s) and to store the user's current Calculation setting before setting Calculation mode to Manual.

'Turn off screenupdating, events, alerts and set calculation to manual
                          With Application
                              .DisplayAlerts = False
                              .EnableEvents = False
                              .ScreenUpdating = False
                              lngCalc = .Calculation
                              .Calculation = xlCalculationManual
                          End With

Open in new window


3) Source worksheet processing
The code tests each source worksheet to ensure that it is not empty. Empty sheets are skipped.

Depending on the user selections, the worksheets are either combined in a single sheet (Options 2 & 3), or a new target worksheet is created for each source worksheet

Part A: single sheet output

For the single sheet summary the code tests:
-  to find the real last row using Find (rather than assume the data is contiguous)
-  whether the remaining available row area in the target sheet will not be exceeded during the copy process
If bNewSheet Then
                          'All data to a single sheet
                          'Skip importing target sheet data if the source sheet is blank
                          Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)
                      
                          If Not rng2 Is Nothing Then
                              Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
                              'Find the first blank row on the target sheet
                              If Not rng1 Is Nothing Then
                                  Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
                                  'Ensure that the row area in the target sheet won't be exceeded
                                  If rng3.Rows.Count + rng1.Row < Rows.Count Then
                                      'Copy the data from the used range of each source sheet to the first blank row
                                      'of the target sheet, using the starting column address from the source sheet being copied
                                      ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
                                  Else
                                      MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
                                             "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
                                      Wb2.Close False
                                      Exit Do
                                  End If
                                  'colour the first of any spacer rows
                                  If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
                              Else
                                  'target sheet is empty so copy to first row
                                  ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                              End If
                          End If

Open in new window


If the user has added a spacer row (using the lrowSpace variable) then this row is coloured green.
If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen

Open in new window


Part B: multi-sheet output

With this approach each worksheet from each source workbook is copied to the summary workbook. Given there are multiple workbooks the code needs to test for duplicate worksheet names, and rename potential duplicate names with a unique name.
Else
                          'new target sheet for each source sheet
                          ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
                          'Remove any links in our target sheet
                          With Wb1.Sheets(Wb1.Sheets.Count).Cells
                              .Copy
                              .PasteSpecial xlPasteValues
                          End With
                          On Error Resume Next
                          Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
                          'sheet name already exists in target workbook
                          If Err.Number <> 0 Then
                              'Add a number to the sheet name till a unique name is derived
                              Do
                                  lSht = lSht + 1
                                  Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
                              Loop While Not ws3 Is Nothing
                              lSht = 0
                          End If
                          On Error GoTo 0
                      End If

Open in new window


4) Tidying up

For the single target sheet option a simplecopy and paste special as values is used to remove any links on the target sheet.
If the user selected the mult-sheet target option then the summary worksheet is selected and formatted so that it is active when the code exits.
'Remove any links if the user has used a target sheet
                          If bNewSheet Then
                              With ws1.UsedRange
                                  .Copy
                                  .Cells(1).PasteSpecial xlPasteValues
                                  .Cells(1).Activate
                              End With
                          Else
                              'Format the summary sheet if the user has created separate target sheets
                              ws1.Activate
                              ws1.Range("A1:B1").Font.Bold = True
                              ws1.Columns.AutoFit
                          End If

Open in new window


5) Reset the Excel environment
The Application settings are re-enabled, and Calculation is returned to it's pre code setting.
'Reset the Excel environment
                          With Application
                              .CutCopyMode = False
                              .DisplayAlerts = True
                              .EnableEvents = True
                              .ScreenUpdating = True
                              .Calculation = lngCalc
                              .StatusBar = vbNullString
                          End With

Open in new window


Full Code


Public Sub ConsolidateSheets()
                          Dim Wb1 As Workbook
                          Dim Wb2 As Workbook
                          Dim ws1 As Worksheet
                          Dim ws2 As Worksheet
                          Dim ws3 As Worksheet
                          Dim rng1 As Range
                          Dim rng2 As Range
                          Dim rng3 As Range
                          Dim rngArea As Range
                          Dim lrowSpace As Long
                          Dim lSht As Long
                          Dim lngCalc As Long
                          Dim lngRow As Long
                          Dim lngCol As Long
                          Dim X()
                          Dim bProcessFolder As Boolean
                          Dim bNewSheet As Boolean
                      
                          Dim StrPrefix
                          Dim strFileName As String
                          Dim strFolderName As String
                      
                          'variant declaration needed for the Shell object to use a default directory
                          Dim strDefaultFolder As Variant
                      
                      
                       bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes)
                          bNewSheet = (MsgBox("Extract all data to a single sheet (Yes)," & vbNewLine & "or a target file sheet for each source sheet (No)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes)
                          If Not bProcessFolder Then
                              If Not bNewSheet Then
                                  MsgBox "There isn't much point creating a exact replica of your source file :)"
                                  Exit Sub
                              End If
                          End If
                      
                          'set default directory here if needed
                          strDefaultFolder = "C:\temp"
                      
                          'If the user is collating all the sheets to a single target sheet then the row spacing
                          'to distinguish between different sheets can be set here
                          lrowSpace = 1
                      
                          If bProcessFolder Then
                              strFolderName = BrowseForFolder(strDefaultFolder)
                              'Look for xls, xlsx, xlsm files
                              strFileName = Dir(strFolderName & "\*.xls*")
                          Else
                              strFileName = Application _
                                            .GetOpenFilename("Select file to process (*.xls*), *.xls*")
                          End If
                      
                          Set Wb1 = Workbooks.Add(1)
                          Set ws1 = Wb1.Sheets(1)
                          If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")
                      
                          'Turn off screenupdating, events, alerts and set calculation to manual
                          With Application
                              .DisplayAlerts = False
                              .EnableEvents = False
                              .ScreenUpdating = False
                              lngCalc = .Calculation
                              .Calculation = xlCalculationManual
                          End With
                      
                          'set path outside the loop
                          StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)
                      
                          Do While Len(strFileName) > 0
                              'Provide progress status to user
                              Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
                              'Open each workbook in the folder of interest
                              Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
                              If Not bNewSheet Then
                                  'add summary details to first sheet
                                  ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
                                  ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
                              End If
                              For Each ws2 In Wb2.Sheets
                                  If bNewSheet Then
                                      'All data to a single sheet
                                      'Skip importing target sheet data if the source sheet is blank
                                      Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)
                      
                                      If Not rng2 Is Nothing Then
                                          Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
                                          'Find the first blank row on the target sheet
                                          If Not rng1 Is Nothing Then
                                              Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
                                              'Ensure that the row area in the target sheet won't be exceeded
                                              If rng3.Rows.Count + rng1.Row < Rows.Count Then
                                                  'Copy the data from the used range of each source sheet to the first blank row
                                                  'of the target sheet, using the starting column address from the source sheet being copied
                                                  ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
                                              Else
                                                  MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
                                                         "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
                                                  Wb2.Close False
                                                  Exit Do
                                              End If
                                              'colour the first of any spacer rows
                                              If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
                                          Else
                                              'target sheet is empty so copy to first row
                                              ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                                          End If
                                      End If
                                  Else
                                      'new target sheet for each source sheet
                                      ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
                                      'Remove any links in our target sheet
                                      With Wb1.Sheets(Wb1.Sheets.Count).Cells
                                          .Copy
                                          .PasteSpecial xlPasteValues
                                      End With
                                      On Error Resume Next
                                      Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
                                      'sheet name already exists in target workbook
                                      If Err.Number <> 0 Then
                                          'Add a number to the sheet name till a unique name is derived
                                          Do
                                              lSht = lSht + 1
                                              Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
                                          Loop While Not ws3 Is Nothing
                                          lSht = 0
                                      End If
                                      On Error GoTo 0
                                  End If
                              Next ws2
                              'Close the opened workbook
                              Wb2.Close False
                              'Check whether to force a DO loop exit if processing a single file
                              If bProcessFolder = False Then Exit Do
                              strFileName = Dir
                          Loop
                      
                          'Remove any links if the user has used a target sheet
                          If bNewSheet Then
                              With ws1.UsedRange
                                  .Copy
                                  .Cells(1).PasteSpecial xlPasteValues
                                  .Cells(1).Activate
                              End With
                          Else
                              'Format the summary sheet if the user has created separate target sheets
                              ws1.Activate
                              ws1.Range("A1:B1").Font.Bold = True
                              ws1.Columns.AutoFit
                          End If
                      
                          With Application
                              .CutCopyMode = False
                              .DisplayAlerts = True
                              .EnableEvents = True
                              .ScreenUpdating = True
                              .Calculation = lngCalc
                              .StatusBar = vbNullString
                          End With
                      End Sub
                      
                      
                      Function BrowseForFolder(Optional OpenAt As Variant) As Variant
                      'From Ken Puls as used in his vbaexpress.com article
                      'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284
                      
                          Dim ShellApp As Object
                          'Create a file browser window at the default folder
                          Set ShellApp = CreateObject("Shell.Application"). _
                                         BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
                      
                          'Set the folder to that selected.  (On error in case cancelled)
                          On Error Resume Next
                          BrowseForFolder = ShellApp.self.Path
                          On Error GoTo 0
                      
                          'Destroy the Shell Application
                          Set ShellApp = Nothing
                      
                          'Check for invalid or non-entries and send to the Invalid error
                          'handler if found
                          'Valid selections can begin L: (where L is a letter) or
                          '\\ (as in \\servername\sharename.  All others are invalid
                          Select Case Mid(BrowseForFolder, 2, 1)
                          Case Is = ":"
                              If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
                          Case Is = "\"
                              If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
                          Case Else
                              GoTo Invalid
                          End Select
                      
                          Exit Function
                      
                      Invalid:
                          'If it was determined that the selection was invalid, set to False
                          BrowseForFolder = False
                      End Function

Open in new window

 

=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
If you liked this article and want to see more from this author, please click here.

If you found this article helpful, please click the Yes button near the:

      Was this article helpful?

label that is just below and to the right of this text.   Thanks!
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
45
12,154 Views
Dave
CERTIFIED EXPERT

Comments (28)

Commented:
Hi Dave,

Nice article..  How would I modify to only pull out a single table "machine parts"; table may span multiple tabs?

Regards,
JD
Hi Dave,
I'm from Malaysia,

Great Article... I want to use the macro for my raw data arrangement,
my raw data is in many .xls files, all in

A1 ........ Blank
A(Blank) --------- Blank

I need to arrange each column in different sheets in 1 .xls file, like this

data (sheet1)             data (sheet2)          untill blank...
column A                    column B              untill blank...


regards
crownterm
Great article, but I was wondering what this piece was after the full code:

If bProcessFolder Then
    strFolderName = BrowseForFolder(strDefaultFolder)
    'Look for xls, xlsx, xlsm files
    strFileName = Dir(strFolderName & "\*.xls*")
Else
    strFileName = Application _
                  .GetOpenFilename("Select file to process (*.xls), *.xls")
End If

Open in new window

Commented:
Hi Dave,

Brilliant article which has saved loads of time. I'm very new to VBA and found this extremely useful.  

Is it possible to amend and identify when the first row of each file do not match?  i.e. someone has inserted / or moved / deleted a column?

maybe just bring back the first row of each worksheet and put onto another summary sheet and identify if not exact match ?

Thanks very much.
Cliff
Hi Dave,

Excellent article.

I tried to implement your sugestion:

If you wanted to keep the header row from the first sheet then use
   If ws2.Index > 1 Then ws1.Cells(rng1.Row + 1 + lrowSpace, "A").EntireRow.Delete

It didn't work for me. Is there any other solution?

Thank you very much.

Regards

Celio

View More

Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.