<

Collating worksheets from one or more workbooks into a summary file

Published on
41,857 Points
9,357 Views
45 Endorsements
Last Modified:
Awarded
Editor's Choice
Community Pick

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
Author:Dave
Enjoy this complimentary article view.

Get unlimited access to our entire library of technical procedures, guides, and tutorials written by certified industry professionals.

Get 7 days free
Click here to view the full article

Using this article for work? Experts Exchange can benefit your whole team.

Learn More
COLLABORATE WITH CERTIFIED PROFESSIONALS
Experts Exchange is a tech solutions provider where users receive personalized tech help from vetted certified professionals. These industry professionals also write and publish relevant articles on our site.
Ask questions about what you read
If you have a question about something within an article, you can receive help directly from the article author. Experts Exchange article authors are available to answer questions and further the discussion.
Learn from the best.