Apr 02 2021 02:59 AM
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
Apr 02 2021 03:33 AM
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?
Apr 06 2021 11:41 AM
@Hans Vogelaar
Hello! :)
All sheets do have the same names and I do not want to skip any sheets.
Thanks in advantage!
Apr 06 2021 12:24 PM
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
Apr 06 2021 11:07 PM
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!
Apr 07 2021 12:47 AM
Am I correct in understanding that you want to end up with 10 sheets?
Apr 07 2021 01:26 AM
@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
Apr 07 2021 03:04 AM
I'll work on it.
Apr 07 2021 03:58 AM
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
Apr 07 2021 04:28 AM
Apr 07 2021 05:05 AM
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
Apr 08 2021 04:38 AM
Apr 08 2021 05:35 AM
Which line is highlighted if you click Debug in the error message?
Apr 11 2021 11:32 PM
Apr 12 2021 03:41 AM
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.
Apr 12 2021 03:47 AM
Apr 12 2021 03:50 AM
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
Apr 12 2021 03:56 AM
Apr 12 2021 04:09 AM
Please tell us what the error message says.
Apr 12 2021 04:15 AM