Combine common worksheet names when splitting a file

[Paul_Hossler]

You have a number of assumptions about WS names, etc.

Option Explicit


Sub SplitWorkbook()
    Dim sNames As String, sName As String
    Dim ws As Worksheet
    Dim aryNames As Variant
    Dim wbName As Workbook
    Dim iName As Long
    
    Application.ScreenUpdating = False
    
    'build string of WS names that do NOT end with a )
    For Each ws In Worksheets
        If Right(ws.Name, 1) <> ")" Then
            sNames = sNames & ws.Name & ";"
        End If
    Next
        
    If Right(sNames, 1) = ";" Then sNames = Left(sNames, Len(sNames) - 1)
    
    'put WS base names into array
    aryNames = Split(sNames, ";")
    
    
    For i = LBound(aryNames) To UBound(aryNames)
        
        'copy base WS to make new WB
        Worksheets(aryNames(i)).Copy
        Set wbName = ActiveWorkbook
        
        'add the (2) and (3) WS to new WB
        ThisWorkbook.Worksheets(aryNames(i) & " (2)").Copy After:=wbName.Sheets(1)
        ThisWorkbook.Worksheets(aryNames(i) & " (3)").Copy After:=wbName.Sheets(2)


        'build the new WB name = this path + base name
        sName = ThisWorkbook.Path & Application.PathSeparator & aryNames(i) & ".xlsx"
        
        'delete if it exists
        Application.DisplayAlerts = False
        On Error Resume Next
        Kill sName
        On Error GoTo 0
        Application.DisplayAlerts = True


        'save new WB and close
        wbName.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & aryNames(i) & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    
        ActiveWindow.Close
    Next i


    Application.ScreenUpdating = True


    MsgBox "Done"


End Sub

My crystal ball tells me the next thing will be VBA to email each WB to the designated person