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