Sub CreateGroupIndentLevel()
    Dim i&, lr&, n&, k&, sh As Worksheet, d, m&, p&

    Application.ScreenUpdating = 0
    Set sh = Sheets("Пример") 'название листа
    sh.UsedRange.ClearOutline   'убираем группировки
    sh.[A1].CurrentRegion.Value = sh.[A1].CurrentRegion.Value    'превращаем в значения
    lr = sh.[A1].End(xlDown).Row
    Set d = CreateObject("Scripting.dictionary")
    For n = 1 To 2 'работаем с отступами
        With d
            For i = 2 To lr    'создаем словарь и формируем пром.итоги
                If sh.Cells(i, 1).IndentLevel = n * 2 Then 'по каждому отступу
                    k = k + 1: .Item(k) = i 'запоминаем строки
                    If k > 1 Then sh.Cells(.Item(k - 1), "B").FormulaLocal = "=ПРОМЕЖУТОЧНЫЕ.ИТОГИ(9;B" & .Item(k - 1) + 1 & ":B" & .Item(k) - 1 & ")"
                End If
            Next
            For k = 1 To .Count - 1  'Пробегаем по словарю
                For m = .Item(k) To .Item(k + 1) - 1    'ищем нарушение правильности
                    p = p + 1
                    If sh.Cells(m, 1).IndentLevel < sh.Cells(.Item(k), 1).IndentLevel Then Exit For
                Next

                Select Case m    'строка нарушения, анализируем
                Case .Item(k + 1)
                    If p > 1 Then sh.Rows(.Item(k) + 1 & ":" & .Item(k + 1) - 1).Group
                    If p = 1 Then p = 1    'ничего не делать
                Case Is < d.Item(k + 1)
                    If p > 2 Then sh.Rows(.Item(k) + 1 & ":" & m - 1).Group
                    If p = 2 Then p = 2    'ничего не делать
                End Select
                p = 0
            Next
            k = 0: .RemoveAll
        End With
    Next n
    sh.[B2].FormulaLocal = "=ПРОМЕЖУТОЧНЫЕ.ИТОГИ(9;B3:B" & lr & ")"
End Sub

Sub InsertSumInGroup()
Dim r As Range, x
  For Each r In Columns(6).SpecialCells(xlCellTypeConstants).Areas
    x = WorksheetFunction.sum(r)
    r.Cells(r.count + 1) = x
  Next
End Sub