VBA to Merge Multiple sheets in Workbook by cheking sheet name

[Smerdis13]

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

 

[Smerdis13]

It's Brilliant, Thanks Dear

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

Based on the latest data requirement replace this line...

If InStr(wsSrc.Name, CStr(clnSrcSheets(i))) > 0 Then

...with this:

If CStr(Split(wsSrc.Name, "-")(1) = CStr(clnSrcSheets(i))) Then

 

[Smerdis13]

You will have to replace "YourFileNameHere" with what you want to call the new file but if you put this line of code...

wbDest.SaveAs Filename:=wbSrc.Path & "\YourFileNameHere.xlsm", FileFormat:=52  'FileFormat 52 = .xlsm

...immediately after this line:

Next i

It will do the job.


The file is open


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?

Thanks Dear
for Part1, Now file is saved with desired name perfectly and it is open
for Part 2 you can find the required VBA code which needs to be run on new file

Sub SplitEachWorksheet()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
    ws.Copy
    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & "BT-" & ws.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[Trebor76]

Try this:

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
   
    Call SplitEachWorksheet(wbDest, CStr(wbSrc.Path))
   
    Application.ScreenUpdating = True
   
    MsgBox """" & wbDest.Name & """ has now been created with " & Format(lngNewCount, "#,##0") & " sheets from """ & wbSrc.Name & """.", vbInformation

End Sub
Sub SplitEachWorksheet(wb As Workbook, strPath As String)

    Dim FPath As String
    Dim ws As Worksheet
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
   
    For Each ws In wb.Sheets
        ws.Copy
        Application.ActiveWorkbook.SaveAs Filename:=strPath & "\" & "BT-" & ws.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    Next ws
   
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
   
End Sub

 

[Smerdis13]

Try this:

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
  
    Call SplitEachWorksheet(wbDest, CStr(wbSrc.Path))
  
    Application.ScreenUpdating = True
  
    MsgBox """" & wbDest.Name & """ has now been created with " & Format(lngNewCount, "#,##0") & " sheets from """ & wbSrc.Name & """.", vbInformation

End Sub
Sub SplitEachWorksheet(wb As Workbook, strPath As String)

    Dim FPath As String
    Dim ws As Worksheet
  
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
  
    For Each ws In wb.Sheets
        ws.Copy
        Application.ActiveWorkbook.SaveAs Filename:=strPath & "\" & "BT-" & ws.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    Next ws
  
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
  
End Sub

Thanks alot dear
Now its beyond perfect

 

[Trebor76]

Thanks alot dear
Now its beyond perfect

You're welcome