Split a Worksheet into Tabs or New Workbooks

Maybe:

Sub hangman()
Dim ws As Worksheet
Dim rcell As Range
Set ws = ActiveSheet
    ws.Range("B3").Select
    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
For Each rcell In ws.Range("B2:B" & ActiveSheet.UsedRange.Rows.Count)
    If Right(rcell, 5) = "Total" Then
    
        Range(rcell.Offset(-5, -1), rcell.Offset(-2, 2)).Copy
        Sheets.Add
        Range("A2").Select
        ActiveSheet.Paste
        ActiveSheet.Range("A1").EntireRow.Value = ws.Range("A1").EntireRow.Value
        ws.Rows("1:1").Copy
        ActiveSheet.Rows("1:1").PasteSpecial Paste:=xlPasteFormats
     End If
     ws.Activate
Next rcell
ws.Range("A2").Select
Selection.RemoveSubtotal
ws.Move Before:=Sheets(1)
End Sub