Option Explicit

Sub SplitActiveWorkbook()
    CloseEmptyWb
    SplitWorkbook ActiveWorkbook
End Sub

Private Sub SplitWorkbook(wbFrom As Workbook)
    Dim divisions As Object
    Set divisions = GetDivisions(wbFrom, "Итого", 2)
    If divisions.Count = 0 Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Dim division As Variant
    For Each division In divisions
        Application.StatusBar = division
        ExtractOneDivision division, wbFrom
    Next
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Готово.", vbInformation, "Разделить книгу"
End Sub

Private Sub ExtractOneDivision(ByVal division As String, wbFrom As Workbook)
    Dim wbTarg As Workbook
    Set wbTarg = Workbooks.Add(1)
    
    Dim sh As Worksheet
    For Each sh In wbFrom.Worksheets
        If sh.Visible = xlSheetVisible Then
            If WorksheetFunction.CountIfs(sh.UsedRange.Columns(1), division) > 0 Then
                ExtractOneDivisionFromSheet division, sh, wbTarg
            End If
        End If
    Next
    
    If wbTarg.Sheets.Count = 1 Then
        wbTarg.Close False
    Else
        Application.DisplayAlerts = False
        wbTarg.Sheets(1).Delete
        Application.DisplayAlerts = True
        
        SaveWorkbook wbTarg, division, wbFrom.Path & "\"
        wbTarg.Close False
    End If
End Sub

Private Sub SaveWorkbook(wb As Workbook, division As String, sPath As String)
    Dim sName As String
    sName = division
    ReplaceSymbols sName
    sName = sName & ".xlsx"
    
    Dim sFull As String
    sFull = sPath & sName
    
    On Error Resume Next
    Workbooks(sName).Close False
    Kill sFull
    On Error GoTo 0
    wb.SaveAs sName
    
End Sub

Private Sub ExtractOneDivisionFromSheet(division As String, shFrom As Worksheet, wbTarg As Workbook)
    shFrom.Copy After:=wbTarg.Sheets(wbTarg.Sheets.Count)
    
    Dim shTarg As Worksheet
    Set shTarg = wbTarg.Sheets(wbTarg.Sheets.Count)
    
    Dim rd As Range
    Set rd = shTarg.UsedRange.Columns(1)
    
    Dim yb As Long
    On Error Resume Next
    yb = WorksheetFunction.Match(division, rd, 0)
    On Error GoTo 0
    If yb = 0 Then Exit Sub
    
    Dim divIndentLevel As Long
    divIndentLevel = rd.Cells(yb, 1).IndentLevel
    
    Dim yf As Long
    For yf = yb + 1 To rd.Rows.Count
        If rd.Cells(yf, 1).IndentLevel <= divIndentLevel Then Exit For
    Next
    yf = yf - 1
    
    If yf < rd.Rows.Count Then
        With shTarg
            .Range(rd.Cells(yf + 1), rd.Cells(rd.Rows.Count, 1)).EntireRow.Delete
        End With
    End If
    
    Dim yy As Long
    For yy = yb - 1 To 1 Step -1
        If rd.Cells(yy, 1).IndentLevel >= divIndentLevel Then
            rd.Cells(yy).EntireRow.Delete
        End If
    Next
    
End Sub

Private Function GetDivisionIndentLevel(rd As Range, division As String) As Long
    Dim yy As Long
    On Error Resume Next
    yy = WorksheetFunction.Match(division, rd, 0)
    On Error GoTo 0
    If yy > 0 Then
        GetDivisionIndentLevel = rd.Cells(yy, 1).IndentLevel
    End If
End Function

Private Function GetDivisions(wb As Workbook, sheetName As String, needIndentLevel As Long) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim sh As Worksheet
    On Error Resume Next
    Set sh = wb.Sheets(sheetName)
    On Error GoTo 0
    If Not sh Is Nothing Then
        Dim cl As Range
        For Each cl In sh.UsedRange.Columns(1).Cells
            If cl.IndentLevel = needIndentLevel Then
                dic(cl.Value) = 0
            End If
        Next
    End If
    
    Set GetDivisions = dic
End Function

Private Sub ReplaceSymbols(ss As String)
    Dim vv As Variant
    For Each vv In Array("\", "/", ":", "*", "?", """", "<", ">", "|", "[", "]") '[] недопустимые только в имени листа
        ss = Replace(ss, vv, " ")
    Next
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub