aggregate sheets from many excel workbooks into one workbook

Question

I want to put the worksheets from several (2-5) excel workbooks (files) into one single workbook.

The names of the workbooks are not standardized and so I opted for a dialog box to select the workbooks.

Here is the code. It meets the basic requirement that all the worksheets (sheets actually) from the selected files are collected into a single file (the ActiveWorkbook).

Sub openDialogBoxAndSelectFiles()

  Dim wb1 As Workbook
  Set wb1 = ActiveWorkbook

  With Application.FileDialog(msoFileDialogFilePicker)

    .AllowMultiSelect = True
    .InitialFileName = ThisWorkbook.path & "\"
    .Title = "Paddington Bear Selection Window"
    .ButtonName = "Omlette"

    .Filters.Clear
    .Filters.Add "All Files", "*.*"

    If .Show = True Then

      Dim file As Variant
      For Each file In .SelectedItems

        Dim wb2 As Workbook
        Set wb2 = Workbooks.Open(Filename:=file, ReadOnly:=True)

        Dim i As Long
        For i = 1 To wb2.Sheets.Count
          wb2.Sheets(i).Copy before:=wb1.Sheets(1)
        Next i

        wb2.Close
      Next

    End If

  End With

End Sub

The code is pretty clean (I think) for the time being and pretty much fits the bill, but that's because it doesn't do the following:

If the ActiveWorkbook which I've defined as wb1 has blank sheets (and a wb has to have at least 1 sheet), once this process is done, I will have a few blank sheets left over.

So if file1.worksheets.count = 4, and file2.worksheets.count = 5, I will have a minimum of 10 (1 + 4 + 5) worksheets in the final workbook.

Questions:

1. Insofar as aggregating the sheets of the files is concerned, is this a reasonable way of doing it?
2. Is there a simple of ensuring there are no blank worksheets left over? Unless the input files have blank sheets that is.

Kindly,

Answer 1

I think the way you are doing this is reasonable. Regarding pre-existing blank sheets..The rewritten code below removes blank worksheet(s) in the importing workbook, after the selected workbooks' worksheets have been inserted.

Sub openDialogBoxAndSelectFiles()

  Dim wb1 As Workbook
  Set wb1 = ActiveWorkbook

    'Cache worksheet references
    Dim originalWorksheets As Collection
    Set originalWorksheets = New Collection
    For i = 1 To wb1.Sheets.Count
      originalWorksheets.Add wb1.Sheets(i)
    Next i

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Paddington Bear Selection Window"
        .ButtonName = "Omlette"

        .Filters.Clear
        'only interested in Exel workbooks
        .Filters.Add "All Files", "*.xls*"


        If .Show = True Then
            For Each file In .SelectedItems
                ImportWorksheets wb1, file
            Next file
        End If
    End With

    'Delete non-imported blank worksheets
    If wb1.Sheets.Count > originalWorksheets.Count Then
        DeleteBlankSheets originalWorksheets
    End If

End Sub

Private Sub ImportWorksheets(ByRef wb1 As Workbook, ByVal filename As Variant)
On Error GoTo ErrorExit
    Dim wb2 As Workbook
    Set wb2 = Workbooks.Open(filename:=filename, ReadOnly:=True)

On Error GoTo WorkbookOpenError
    Dim i As Long
    For i = 1 To wb2.Sheets.Count
      wb2.Sheets(i).Copy before:=wb1.Sheets(1)
    Next i

WorkbookOpenError:
    wb2.Close

ErrorExit:
End Sub

Private Sub DeleteBlankSheets(ByRef originalWorksheets As Collection)
On Error GoTo ErrorExit

    Dim displayAlertsFlagCurrentValue As Boolean
    displayAlertsFlagCurrentValue = Application.DisplayAlerts

    'Prevent Sheet deletion prompts
    Application.DisplayAlerts = False

    Dim wksht As Worksheet
    For Each wksht In originalWorksheets
        If IsBlank(wksht) Then
            wksht.Delete
        End If
    Next wksht

ErrorExit:
    Application.DisplayAlerts = displayAlertsFlagCurrentValue
End Sub

Private Function IsBlank(ByRef wksht As Worksheet) As Boolean
    IsBlank = WorksheetFunction.CountA(wksht.UsedRange) = 0 And wksht.Shapes.Count = 0
End Function