Combination of multiple excel workbooks with multiple sheets (not in a single sheet)

Copper Contributor

Hello! :)

I am struggeling right now with a task. I try to combine multiple excel workbooks, all with the same structure, so f.e. 5 sheets, each with the same headers, simultan over each workbook, into one workbook with multiple sheets.

So sheet 1 of wb2 is hung at the bottom of sheet1 of wb1 in a new master workbook, same for each other sheet. 
I do have multiple workbooks in multiple folders, all of the sheets have the same headers and I want to choose individually which workbooks I want to combine in the new "Master Workbook".

I am completly struggeling, I was able to combine each wb in a one sheet wb (it is not what I want nor need) and combine this single sheets, but I do not know how to accomplish my task. The best would be a VBA solution.

I would be greatful vor any help

24 Replies

@LaSta95 

Do the worksheets have the same names in each of the workbooks?

Do you want to process all worksheets in the workbooks, or should some sheets be skipped?

@Hans Vogelaar 

Hello! :)
All sheets do have the same names and I do not want to skip any sheets.

 

Thanks in advantage!

@LaSta95 

Try this.

The target workbook should already have the 5 correctly named sheets.

It should be the active workbook when you run the macro.

You'll be prompted for each workbook to process.

Click Cancel when you want to stop.

Sub CombineWorkbooks()
    Dim wbkS As Workbook
    Dim wbkT As Workbook
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim strFile As String
    Dim lngS As Long
    Dim lngT As Long
    Application.ScreenUpdating = False
    Set wbkT = ActiveWorkbook
    Do
        strFile = Application.GetOpenFilename( _
            FileFilter:="Excel Workbooks (*.xls*),*.xls*", _
            Title:="Select a workbook to process. Click Cancel to stop")
        If strFile = "False" Then Exit Do
        Set wbkS = Workbooks.Open(Filename:=strFile)
        For Each wshS In wbkS.Worksheets
            Set wshT = wbkT.Worksheets(wshS.Name)
            lngS = 0
            lngT = 0
            On Error Resume Next
            lngS = wshS.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            lngT = wshT.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            On Error GoTo 0
            If lngS > 1 Then
                If lngT = 0 Then
                    wshS.Range("A1:A" & lngS).EntireRow.Copy Destination:=wshT.Range("A1")
                Else
                    wshS.Range("A2:A" & lngS).EntireRow.Copy Destination:=wshT.Range("A" & lngT + 1)
                End If
            End If
        Next wshS
        wbkS.Close SaveChanges:=False
    Loop
    Application.ScreenUpdating = True
End Sub

@Hans Vogelaar 

 

Thank you Hans, it works! :)
I do have a follow-up question: Do you know if it would be possible to split the newly created master based on a column? so each sheet has a specific column (lets say BZ) and there is either an A or an B as a cell value included. I now want to have my five sheets in the wb seperated into to masters A and B, where I have the same sheet structure.

 

Thanks a lot in advantage! 

@LaSta95 

Am I correct in understanding that you want to end up with 10 sheets?

@Hans Vogelaar 

Hello Hans,

I want to have two (master) workbooks, each has the original 5 sheets, but it is splitted based on the column

so Master 1 has 5 sheets but in column BZ is only A, in each sheet

and Master 2 has 5 sheets buit in column BZ is only B, in each sheet

@LaSta95 

Here is a new macro.

It assumes that the two master workbooks are already open.

Change the constants strA and strB at the beginning of the macro to the actual names of these master workbooks.

Sub CombineWorkbooksAB()
    Const lngSplit = 78 ' Column BZ
    Const strA = "MasterA.xlsx" ' Name of first master workbook
    Const strB = "MasterB.xlsx" ' Name of second master workbook
    Dim wbkS As Workbook
    Dim wbkA As Workbook
    Dim wbkB As Workbook
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim strFile As String
    Dim lngT As Long
    Application.ScreenUpdating = False
    Set wbkA = Workbooks(strA)
    Set wbkB = Workbooks(strB)
    Do
        strFile = Application.GetOpenFilename( _
            FileFilter:="Excel Workbooks (*.xls*),*.xls*", _
            Title:="Select a workbook to process. Click Cancel to stop")
        If strFile = "False" Then Exit Do
        Set wbkS = Workbooks.Open(Filename:=strFile)
        For Each wshS In wbkS.Worksheets
            ' Handle A
            Set wshT = wbkA.Worksheets(wshS.Name)
            wshS.UsedRange.AutoFilter Field:=lngSplit, Criteria1:="A"
            lngT = 0
            On Error Resume Next
            lngT = wshT.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            On Error GoTo 0
            If lngT = 0 Then
                wshS.UsedRange.Copy Destination:=wshT.Range("A1")
            Else
                wshS.UsedRange.Offset(1).Copy Destination:=wshT.Range("A" & lngT + 1)
            End If
            ' Handle B
            Set wshT = wbkB.Worksheets(wshS.Name)
            wshS.UsedRange.AutoFilter Field:=lngSplit, Criteria1:="B"
            lngT = 0
            On Error Resume Next
            lngT = wshT.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            On Error GoTo 0
            If lngT = 0 Then
                wshS.UsedRange.Copy Destination:=wshT.Range("A1")
            Else
                wshS.UsedRange.Offset(1).Copy Destination:=wshT.Range("A" & lngT + 1)
            End If
        Next wshS
        wbkS.Close SaveChanges:=False
    Loop
    Application.ScreenUpdating = True
End Sub
Hello Hans,
I do have one Master Workbook and want to split in two, not the other way around :)
So I have a combined workbook (based on your first macro) and now i want to split it into two, based on the column BZ.

@LaSta95 

Try this then:

Sub SplitAB()
    Const lngSplit = 78 ' Column BZ
    Const strA = "MasterA.xlsx" ' Name of first master workbook
    Const strB = "MasterB.xlsx" ' Name of second master workbook
    Dim wbkS As Workbook
    Dim wbkT As Workbook
    Dim wshT As Worksheet
    Dim lngT As Long
    Application.ScreenUpdating = False
    Set wbkS = ActiveWorkbook
    ' Handle A
    wbkS.Worksheets.Copy
    Set wbkT = ActiveWorkbook
    For Each wshT In wbkT.Worksheets
        wshT.UsedRange.AutoFilter Field:=lngSplit, Criteria1:="B"
        wshT.UsedRange.Offset(1).EntireRow.Delete
        wshT.UsedRange.AutoFilter
    Next wshT
    wbkT.Close SaveChanges:=True, Filename:=strA
    ' Handle B
    wbkS.Worksheets.Copy
    Set wbkT = ActiveWorkbook
    For Each wshT In wbkT.Worksheets
        wshT.UsedRange.AutoFilter Field:=lngSplit, Criteria1:="A"
        wshT.UsedRange.Offset(1).EntireRow.Delete
        wshT.UsedRange.AutoFilter
    Next wshT
    wbkT.Close SaveChanges:=True, Filename:=strB
    Application.ScreenUpdating = True
End Sub
Hello Hans, I get a runtime 1004 error, did you ever heard of that?
Sorry to bother you so much!

@LaSta95 

Which line is highlighted if you click Debug in the error message?

Hello Hans,

wshT.UsedRange.AutoFilter Field:=lngSplit, Criteria1:="B"

@LaSta95 

Could there be empty sheets in the source workbook?

 

It would be helpful if you attached a sample workbook without sensitive data that demonstrates the problem.

Hello Hans,

yes, there could be (temporary) empty sheets in the source workbook.

@LaSta95 

Try this version:

Sub SplitAB()
    Const lngSplit = 78 ' Column BZ
    Const strA = "MasterA.xlsx" ' Name of first master workbook
    Const strB = "MasterB.xlsx" ' Name of second master workbook
    Dim wbkS As Workbook
    Dim wbkT As Workbook
    Dim wshT As Worksheet
    Dim lngT As Long
    Application.ScreenUpdating = False
    Set wbkS = ActiveWorkbook
    ' Handle A
    wbkS.Worksheets.Copy
    Set wbkT = ActiveWorkbook
    For Each wshT In wbkT.Worksheets
        If wshT.UsedRange.Rows.Count > 1 Then
            wshT.UsedRange.AutoFilter Field:=lngSplit, Criteria1:="B"
            wshT.UsedRange.Offset(1).EntireRow.Delete
            wshT.UsedRange.AutoFilter
        End If
    Next wshT
    wbkT.Close SaveChanges:=True, Filename:=strA
    ' Handle B
    wbkS.Worksheets.Copy
    Set wbkT = ActiveWorkbook
    For Each wshT In wbkT.Worksheets
        If wshT.UsedRange.Rows.Count > 1 Then
            wshT.UsedRange.AutoFilter Field:=lngSplit, Criteria1:="A"
            wshT.UsedRange.Offset(1).EntireRow.Delete
            wshT.UsedRange.AutoFilter
        End If
    Next wshT
    wbkT.Close SaveChanges:=True, Filename:=strB
    Application.ScreenUpdating = True
End Sub
Hello Hans, now I get an error here:
wbkT.Close SaveChanges:=True, Filename:=strA

@LaSta95 

Please tell us what the error message says.