Split a Worksheet into Tabs or New Workbooks

Try:

Sub hangman2()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim Y As String

Set ws = ActiveSheet
    ws.Range("B3").Select
    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ws.Range("B3").Select
Do Until ActiveCell = ""
Do Until Right(ActiveCell, 5) = "Total"
    ActiveCell.Offset(1).Select
Loop

Y = Left(ActiveCell, 5)
ws.Cells.Find(What:="*" & Y & "*", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Activate
        Set ws2 = Sheets.Add
        ws2.Range("A1").EntireRow.Value = ws.Range("A1").EntireRow.Value
        ws.Rows("1:1").Copy
        ws2.Rows("1:1").PasteSpecial Paste:=xlPasteFormats
     ws.Activate
     Do Until Left(ActiveCell, 5) <> Y
        Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, 2)).Copy ws2.Range("A" & Rows.Count).End(3)(2)
        ActiveCell.Offset(1).Select
     Loop
     ws2.Activate
     ws2.Range("B" & ws2.UsedRange.Rows.Count).EntireRow.Insert xlDown
     ws2.Range("D" & ws2.UsedRange.Rows.Count).Font.Bold = True
     ws2.Columns("A:A").ColumnWidth = 8.43
     ws2.Columns("B:B").ColumnWidth = 31.14
     ws2.Columns("C:C").ColumnWidth = 31.14
     ws2.Columns("D:D").ColumnWidth = 10.2
     ws.Activate
Loop

ws.Range("A2").RemoveSubtotal
ws.Move Before:=Sheets(1)
Application.DisplayAlerts = False
Sheets(Sheets.Count).Delete
Application.DisplayAlerts = True
End Sub