VBA to Merge Multiple sheets in Workbook by cheking sheet name

Smerdis13

Smerdis13

New Member
Joined
Nov 15, 2023
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
Hi Guys,
I Have One work book with multipe sheets which can be as below:
Sheet 1 = A-January
Sheet 2 = B-January
Sheet 3 = A-April
Sheet 4 = B-April
.....
I Want to merge each sheet with same name after "-" into new sheet with the name after "-" and all of them in new work book:
New work book with sheets as below:
Sheet 1 = January
Sheet 2 = April
.....

Thanks in Advance for the support and environment
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
Sort by date Sort by votes
Hi Smerdis13,

Welcome to MrExcel!!

Let me know how this goes:

VBA Code: 
Option Explicit
Sub Macro1()

    'Sheets in new workbook adapted from here:
    'https://www.extendoffice.com/documents/excel/3164-excel-create-workbook-with-specific-number-of-sheets.html

    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim clnSrcSheets As New Collection
    Dim varSheet As Variant
    Dim lngOldCount As Long, lngNewCount As Long
    Dim lngLastRow As Long, lngLastCol As Long, lngPasteRow As Long
    Dim i As Long
    Dim wbSrc As Workbook, wbDest As Workbook
    
    Application.ScreenUpdating = False
    
    Set wbSrc = ThisWorkbook
    lngOldCount = Application.SheetsInNewWorkbook
    
    For Each wsSrc In wbSrc.Sheets
        On Error Resume Next
            clnSrcSheets.Add CStr(Split(wsSrc.Name, "-")(1)), Split(wsSrc.Name, "-")(1)
        On Error GoTo 0
    Next wsSrc
    
    lngNewCount = clnSrcSheets.Count
    
    If (lngNewCount < 1) Or (CLng(lngNewCount) > 255) Then
        MsgBox "Cannot create a new workbook as the number of sheets must between 1 and 255 but the code has returned " & Format(lngNewCount, "#,##0") & ".", vbExclamation
        Exit Sub
    End If
    
    With Application
        .SheetsInNewWorkbook = lngNewCount
        Set wbDest = .Workbooks.Add
        .SheetsInNewWorkbook = lngOldCount
    End With
    
    For i = 1 To clnSrcSheets.Count
        Set wsDest = wbDest.Sheets(i)
        wsDest.Name = CStr(clnSrcSheets(i))
        For Each wsSrc In wbSrc.Sheets
            If InStr(wsSrc.Name, CStr(clnSrcSheets(i))) > 0 Then
                If WorksheetFunction.CountA(wsSrc.Cells) > 0 Then 'https://forum.ozgrid.com/forum/index.php?thread/50992-check-if-sheet-is-empty
                    lngLastRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    lngLastCol = wsSrc.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
                    If WorksheetFunction.CountA(wsDest.Cells) = 0 Then 'https://forum.ozgrid.com/forum/index.php?thread/50992-check-if-sheet-is-empty
                        'Copy data including headings
                        Range(wsSrc.Cells(1, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Copy Destination:=wsDest.Range("A1")
                    Else
                        'Copy data excluding headings
                        lngPasteRow = wsDest.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        Range(wsSrc.Cells(2, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Copy Destination:=wsDest.Range("A" & lngPasteRow)
                    End If
                End If
            End If
        Next wsSrc
    Next i
    
    Application.ScreenUpdating = False
    
    MsgBox """" & wbDest.Name & """ has now been created with " & Format(lngNewCount, "#,##0") & " sheets from """ & wbSrc.Name & """.", vbInformation

End Sub

Regards,

Robert
 
Upvote 2
Solution
Trebor76 said:
Hi Smerdis13,

Welcome to MrExcel!!

Let me know how this goes:

VBA Code: 
Option Explicit
Sub Macro1()

    'Sheets in new workbook adapted from here:
    'https://www.extendoffice.com/documents/excel/3164-excel-create-workbook-with-specific-number-of-sheets.html

    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim clnSrcSheets As New Collection
    Dim varSheet As Variant
    Dim lngOldCount As Long, lngNewCount As Long
    Dim lngLastRow As Long, lngLastCol As Long, lngPasteRow As Long
    Dim i As Long
    Dim wbSrc As Workbook, wbDest As Workbook
   
    Application.ScreenUpdating = False
   
    Set wbSrc = ThisWorkbook
    lngOldCount = Application.SheetsInNewWorkbook
   
    For Each wsSrc In wbSrc.Sheets
        On Error Resume Next
            clnSrcSheets.Add CStr(Split(wsSrc.Name, "-")(1)), Split(wsSrc.Name, "-")(1)
        On Error GoTo 0
    Next wsSrc
   
    lngNewCount = clnSrcSheets.Count
   
    If (lngNewCount < 1) Or (CLng(lngNewCount) > 255) Then
        MsgBox "Cannot create a new workbook as the number of sheets must between 1 and 255 but the code has returned " & Format(lngNewCount, "#,##0") & ".", vbExclamation
        Exit Sub
    End If
   
    With Application
        .SheetsInNewWorkbook = lngNewCount
        Set wbDest = .Workbooks.Add
        .SheetsInNewWorkbook = lngOldCount
    End With
   
    For i = 1 To clnSrcSheets.Count
        Set wsDest = wbDest.Sheets(i)
        wsDest.Name = CStr(clnSrcSheets(i))
        For Each wsSrc In wbSrc.Sheets
            If InStr(wsSrc.Name, CStr(clnSrcSheets(i))) > 0 Then
                If WorksheetFunction.CountA(wsSrc.Cells) > 0 Then 'https://forum.ozgrid.com/forum/index.php?thread/50992-check-if-sheet-is-empty
                    lngLastRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    lngLastCol = wsSrc.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
                    If WorksheetFunction.CountA(wsDest.Cells) = 0 Then 'https://forum.ozgrid.com/forum/index.php?thread/50992-check-if-sheet-is-empty
                        'Copy data including headings
                        Range(wsSrc.Cells(1, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Copy Destination:=wsDest.Range("A1")
                    Else
                        'Copy data excluding headings
                        lngPasteRow = wsDest.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        Range(wsSrc.Cells(2, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Copy Destination:=wsDest.Range("A" & lngPasteRow)
                    End If
                End If
            End If
        Next wsSrc
    Next i
   
    Application.ScreenUpdating = False
   
    MsgBox """" & wbDest.Name & """ has now been created with " & Format(lngNewCount, "#,##0") & " sheets from """ & wbSrc.Name & """.", vbInformation

End Sub

Regards,

Robert
Click to expand...
wow!
it works perfectly fine. Thanks alot dear for your prompt response
if it is not bother, can you add below:
1-Save the new file as xlsm in same path as source file then open it
2-run another macro in the new file ( i already use another macro to separate mentioned sheets and save the separately in workbooks in same path as source file)
Thanks in advance
 
Upvote 0
1-Save the new file as xlsm in same path as source file
Click to expand...

You will have to replace "YourFileNameHere" with what you want to call the new file but if you put this line of code...
VBA Code: 
wbDest.SaveAs Filename:=wbSrc.Path & "\YourFileNameHere.xlsm", FileFormat:=52  'FileFormat 52 = .xlsm
...immediately after this line:
VBA Code: 
Next i
It will do the job.

then open it
Click to expand...
The file is open :confused:

2-run another macro in the new file ( i already use another macro to separate mentioned sheets and save the separately in workbooks in same path as source file)
Click to expand...
Not sure how you're running the macro or what parameters it needs if any. Maybe tell the code to run on the new workbook using the wbDest variable?
 
Upvote 1
Trebor76 said:
Hi Smerdis13,

Welcome to MrExcel!!

Let me know how this goes:

VBA Code: 
Option Explicit
Sub Macro1()

    'Sheets in new workbook adapted from here:
    'https://www.extendoffice.com/documents/excel/3164-excel-create-workbook-with-specific-number-of-sheets.html

    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim clnSrcSheets As New Collection
    Dim varSheet As Variant
    Dim lngOldCount As Long, lngNewCount As Long
    Dim lngLastRow As Long, lngLastCol As Long, lngPasteRow As Long
    Dim i As Long
    Dim wbSrc As Workbook, wbDest As Workbook
   
    Application.ScreenUpdating = False
   
    Set wbSrc = ThisWorkbook
    lngOldCount = Application.SheetsInNewWorkbook
   
    For Each wsSrc In wbSrc.Sheets
        On Error Resume Next
            clnSrcSheets.Add CStr(Split(wsSrc.Name, "-")(1)), Split(wsSrc.Name, "-")(1)
        On Error GoTo 0
    Next wsSrc
   
    lngNewCount = clnSrcSheets.Count
   
    If (lngNewCount < 1) Or (CLng(lngNewCount) > 255) Then
        MsgBox "Cannot create a new workbook as the number of sheets must between 1 and 255 but the code has returned " & Format(lngNewCount, "#,##0") & ".", vbExclamation
        Exit Sub
    End If
   
    With Application
        .SheetsInNewWorkbook = lngNewCount
        Set wbDest = .Workbooks.Add
        .SheetsInNewWorkbook = lngOldCount
    End With
   
    For i = 1 To clnSrcSheets.Count
        Set wsDest = wbDest.Sheets(i)
        wsDest.Name = CStr(clnSrcSheets(i))
        For Each wsSrc In wbSrc.Sheets
            If InStr(wsSrc.Name, CStr(clnSrcSheets(i))) > 0 Then
                If WorksheetFunction.CountA(wsSrc.Cells) > 0 Then 'https://forum.ozgrid.com/forum/index.php?thread/50992-check-if-sheet-is-empty
                    lngLastRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    lngLastCol = wsSrc.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
                    If WorksheetFunction.CountA(wsDest.Cells) = 0 Then 'https://forum.ozgrid.com/forum/index.php?thread/50992-check-if-sheet-is-empty
                        'Copy data including headings
                        Range(wsSrc.Cells(1, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Copy Destination:=wsDest.Range("A1")
                    Else
                        'Copy data excluding headings
                        lngPasteRow = wsDest.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        Range(wsSrc.Cells(2, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Copy Destination:=wsDest.Range("A" & lngPasteRow)
                    End If
                End If
            End If
        Next wsSrc
    Next i
   
    Application.ScreenUpdating = False
   
    MsgBox """" & wbDest.Name & """ has now been created with " & Format(lngNewCount, "#,##0") & " sheets from """ & wbSrc.Name & """.", vbInformation

End Sub

Regards,

Robert
Click to expand...
Dear
For first code, it seems there is a bug as below:
consider if
Sheet 1 = A-Cell
Sheet 2 = B-Cell
Sheet 3 = A-CellAlgo
Sheet 4 = B-CellAlgo
when it is trying to merge A-Cell & B-Cell, it is also merges A-Cellalgo & B-Cellalgo to the "Cell" too
it seems every sheet which after "-" starts with "Cell" matches to final sheet "Cell"
it needs to differ between "Cell" and "Cellalgo" or anysheet name like this
Thanks
 
Upvote 0
For first code, it seems there is a bug as below
Click to expand...

No, I based the code on the data sample you gave which worked fine.

Based on the latest data requirement replace this line...
VBA Code: 
If InStr(wsSrc.Name, CStr(clnSrcSheets(i))) > 0 Then
...with this:
VBA Code: 
If CStr(Split(wsSrc.Name, "-")(1) = CStr(clnSrcSheets(i))) Then
 
Upvote 1
Trebor76 said:
Hi Smerdis13,

Welcome to MrExcel!!

Let me know how this goes:

VBA Code: 
Option Explicit
Sub Macro1()

    'Sheets in new workbook adapted from here:
    'https://www.extendoffice.com/documents/excel/3164-excel-create-workbook-with-specific-number-of-sheets.html

    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim clnSrcSheets As New Collection
    Dim varSheet As Variant
    Dim lngOldCount As Long, lngNewCount As Long
    Dim lngLastRow As Long, lngLastCol As Long, lngPasteRow As Long
    Dim i As Long
    Dim wbSrc As Workbook, wbDest As Workbook
    
    Application.ScreenUpdating = False
    
    Set wbSrc = ThisWorkbook
    lngOldCount = Application.SheetsInNewWorkbook
    
    For Each wsSrc In wbSrc.Sheets
        On Error Resume Next
            clnSrcSheets.Add CStr(Split(wsSrc.Name, "-")(1)), Split(wsSrc.Name, "-")(1)
        On Error GoTo 0
    Next wsSrc
    
    lngNewCount = clnSrcSheets.Count
    
    If (lngNewCount < 1) Or (CLng(lngNewCount) > 255) Then
        MsgBox "Cannot create a new workbook as the number of sheets must between 1 and 255 but the code has returned " & Format(lngNewCount, "#,##0") & ".", vbExclamation
        Exit Sub
    End If
    
    With Application
        .SheetsInNewWorkbook = lngNewCount
        Set wbDest = .Workbooks.Add
        .SheetsInNewWorkbook = lngOldCount
    End With
    
    For i = 1 To clnSrcSheets.Count
        Set wsDest = wbDest.Sheets(i)
        wsDest.Name = CStr(clnSrcSheets(i))
        For Each wsSrc In wbSrc.Sheets
            If InStr(wsSrc.Name, CStr(clnSrcSheets(i))) > 0 Then
                If WorksheetFunction.CountA(wsSrc.Cells) > 0 Then 'https://forum.ozgrid.com/forum/index.php?thread/50992-check-if-sheet-is-empty
                    lngLastRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    lngLastCol = wsSrc.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
                    If WorksheetFunction.CountA(wsDest.Cells) = 0 Then 'https://forum.ozgrid.com/forum/index.php?thread/50992-check-if-sheet-is-empty
                        'Copy data including headings
                        Range(wsSrc.Cells(1, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Copy Destination:=wsDest.Range("A1")
                    Else
                        'Copy data excluding headings
                        lngPasteRow = wsDest.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        Range(wsSrc.Cells(2, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Copy Destination:=wsDest.Range("A" & lngPasteRow)
                    End If
                End If
            End If
        Next wsSrc
    Next i
    
    Application.ScreenUpdating = False
    
    MsgBox """" & wbDest.Name & """ has now been created with " & Format(lngNewCount, "#,##0") & " sheets from """ & wbSrc.Name & """.", vbInformation

End Sub

Regards,

Robert
Click to expand...
A very, very cool code that I have been looking for for a while. Please, is it possible within the code to specify the copied columns or ranges?
 
Upvote 0
A very, very cool code that I have been looking for for a while.
Click to expand...

Thank you 👍

Please, is it possible within the code to specify the copied columns or ranges?
Click to expand...

Not too sure what you mean :confused:
The ranges being copied are under the headings "Copy data including headings" and "Copy data including headings" depending on whether the tab is being populated for the first time or not.
You can see the range address for the range with headings like so:

VBA Code: 
Debug.Print Range(wsSrc.Cells(1, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Address
 
Upvote 0
Trebor76 said:
Thank you 👍



Not too sure what you mean :confused:
The ranges being copied are under the headings "Copy data including headings" and "Copy data including headings" depending on whether the tab is being populated for the first time or not.
You can see the range address for the range with headings like so:

VBA Code: 
Debug.Print Range(wsSrc.Cells(1, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Address
Click to expand...
I mean I want to copy range("B2:M & lastrow) data Just nothing else
 
Upvote 0
I think I'll need to see your code. As I understand it all that's needed is for you to replace my code with yours but I account for the sheet being pasted into being blank tab or not which you may or may not need.
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question
VBA - add formula to cell when created
Replies
2
Views
297
Golaidron
G
Smerdis13
  • Solved
VBA to Merge Workbooks in a folder by checking workbook names
Replies
5
Views
402
eiloken
E
P
  • Question
Need VBA to automatically copy paste rows based on dates of current month.
2
Replies
11
Views
249
pk970
P
D
  • Solved
Save multiple sheets in a new workbook
Replies
4
Views
287
Dave_george
D
R
  • Question
Functions with XLM macros are blocked
Replies
1
Views
181
MARK858
MARK858

Forum statistics

Threads
1,215,103
Messages
6,123,110
Members
449,096
Latest member
provoking

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top