2
\$\begingroup\$

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,

\$\endgroup\$
2
\$\begingroup\$

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
\$\endgroup\$
3
  • \$\begingroup\$ This would certainly solve the problem. I was considering something similar but it seemed kind of inelegant. I will keep this open for a bit longer, but it might just be the answer. \$\endgroup\$ Feb 24 '20 at 2:38
  • \$\begingroup\$ In the end, the only thing I did differently is that I saved the original worksheet names as a collection, instead of the ws objects. \$\endgroup\$ Feb 26 '20 at 2:04
  • \$\begingroup\$ Perfectly good solution to use worksheet names in this context. \$\endgroup\$
    – BZngr
    Feb 26 '20 at 4:02

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.