View Full Version : [SOLVED:] Merge specific worksheet from multiple workbooks into a single worksheet
jimmylee_sg
04-04-2018, 07:40 AM
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...
jimmylee_sg
04-08-2018, 04:36 PM
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
04-09-2018, 02:23 AM
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
04-09-2018, 09:00 AM
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
04-09-2018, 02:55 PM
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
04-09-2018, 04:59 PM
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
04-12-2018, 03:06 AM
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
04-12-2018, 03:40 AM
Dear xld,
Everything came out beautifully the way I wanted. Thank you!!! :clap::clap::clap:
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.