Hello CharlieP,

I revised your macro. It will scan the worksheets for unique names and associate the like named worksheets with the names. A workbook will be created for each unique name and the associated worksheets will be copied into it.

Sub SplitBook1()


    Dim Dict        As Object
    Dim Key         As Variant
    Dim n           As Long
    Dim Wkb         As Workbook
    Dim Wks         As Worksheet
    Dim WksObjs()   As Variant
        
        Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
            '// Associate worksheets with names.
            For Each Wks In ThisWorkbook.Worksheets
                n = InStrRev(Wks.Name, " ")
                
                If n > 1 Then
                    Key = Left(Wks.Name, n - 1)
                Else
                    Key = Wks.Name
                End If
                
                If Not Dict.Exists(Key) Then
                    ReDim WksObjs(0)
                        Set WksObjs(0) = Wks
                    Dict.Add Key, WksObjs
                Else
                    WksObjs = Dict(Key)
                        n = UBound(WksObjs) + 1
                        ReDim Preserve WksObjs(n)
                        Set WksObjs(n) = Wks
                    Dict(Key) = WksObjs
                End If
            Next Wks
                
        '// Create workbooks from names and load with associated worksheets.
        For Each Key In Dict.Keys
            WksObjs = Dict(Key)
            WksObjs(0).Copy
            Set Wkb = ActiveWorkbook
                For n = 1 To UBound(WksObjs)
                    Set Wks = WksObjs(n)
                    Wks.Copy After:=Wkb.Worksheets(Wkb.Worksheets.Count)
                Next n
            Wkb.SaveAs ThisWorkbook.Path & Key & ".xlsx"
        Next Key
        
End Sub