Merge specific worksheet from multiple workbooks into a single worksheet

[jimmylee_sg]

I have multiple workbooks where each of them contains same number of similar naming worksheets. Would like to know how to merge specific same naming worksheets into a single worksheet. All these workbooks are under the same folder. Many thanks in advance...

[SamT]

Moderator Bump

[jimmylee_sg]

Thanks for the bump.

I have only manage to combine all the files in the same directory using the macro below. Next challenge is to merge all the same naming Tabs into separate worksheets. Any help will be appreciated....


Sub ConslidateWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = Environ("userprofile") & "\Documents\Reports"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub

[Bob Phillips]

Not tested, but does this do what you want?


Public Sub ConslidateWorkbooks()
Dim this As Workbook
Dim Sheet As Worksheet
Dim Nextcell As Range
Dim FolderPath As String
Dim Filename As String
Dim Lastrow As Long

Application.ScreenUpdating = False

FolderPath = Environ("userprofile") & "\Documents\Reports"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""

Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True

For Each Sheet In ActiveWorkbook.Sheets

Call SheetExists(Sheet.Name, ThisWorkbook, True)
Lastrow = ThisWorkbook.Worksheets(Sheet.Name).Range("A1").SpecialCells(xlCellTypeLastCell).Row

Sheet.UsedRange.Copy
ThisWorkbook.Worksheets(Sheet.Name).Range(Lastrow + 1, "A").Paste
Next Sheet

Workbooks(Filename).Close
Filename = Dir()
Loop

Application.ScreenUpdating = True
End Sub

Public Function SheetExists( _
ByVal Name As String, _
Optional ByRef Wb As Workbook, _
Optional ByVal Create As Boolean = False) As Boolean
Dim res As Boolean

If Wb Is Nothing Then Set Wb = ActiveWorkbook
On Error Resume Next
res = CBool(Not Wb.Worksheets(Name) Is Nothing)
If Not res And Create Then Wb.Worksheets.Add After:=Wb.Worksheets(Wb.Worksheets.Count)
SheetExists = res
End Function

[jimmylee_sg]

Hi xld, thanks for helping.

Unfortunately, the macro ran into "Run-time error '9': Subscript out of range" at


Lastrow = ThisWorkbook.Worksheets(Sheet.Name).Range("A1").SpecialCells(xlCellTypeLastCell).Row

[Bob Phillips]

That means the code failed to find that sheet in the target workbook. My code (was meant to) creates that sheet if it doesn't exist, so it probably went wrong there. Can you post two of the sample input files, then I can test where it goes wrong?

[jimmylee_sg]

My goal is to merge same naming worksheets from different workbooks into a single new workbook using back the same worksheet names... Thanks!

[Bob Phillips]

This should be better


Public Sub ConslidateWorkbooks()
Dim this As Workbook
Dim Sheet As Worksheet
Dim Nextcell As Range
Dim FolderPath As String
Dim Filename As String
Dim Lastrow As Long

Application.ScreenUpdating = False

FolderPath = Environ("userprofile") & "\Documents\Reports\"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""

Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True

For Each Sheet In ActiveWorkbook.Sheets

Call SheetExists(Sheet.Name, ThisWorkbook, True)
Lastrow = ThisWorkbook.Worksheets(Sheet.Name).Range("A1").SpecialCells(xlCellTypeLastCell).Row
If Lastrow = 1 And ThisWorkbook.Worksheets(Sheet.Name).Range("A1").Value = vbNullString Then Lastrow = 0

Sheet.UsedRange.Copy ThisWorkbook.Worksheets(Sheet.Name).Cells(Lastrow + 1, "A")
Next Sheet

Workbooks(Filename).Close
Filename = Dir()
Loop

Application.ScreenUpdating = True
End Sub

Public Function SheetExists( _
ByVal Name As String, _
Optional ByRef Wb As Workbook, _
Optional ByVal Create As Boolean = False) As Boolean
Dim res As Boolean

If Wb Is Nothing Then Set Wb = ActiveWorkbook
On Error Resume Next
res = CBool(Not Wb.Worksheets(Name) Is Nothing)
If Not res And Create Then

Wb.Worksheets.Add After:=Wb.Worksheets(Wb.Worksheets.Count)
Wb.Worksheets(Wb.Worksheets.Count).Name = Name
End If
SheetExists = res
End Function

[jimmylee_sg]

Dear xld,

Everything came out beautifully the way I wanted. Thank you!!! :clap::clap::clap: