Sub DeleteOutlineLevels()
    Dim r As Range, ar As Range
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0
        With .ActiveSheet
            .Outline.ShowLevels RowLevels:=3
            Set r = .UsedRange.SpecialCells(12)
            .Outline.ShowLevels RowLevels:=8
            r.EntireRow.Hidden = 1
            On Error Resume Next
            For Each ar In .UsedRange.SpecialCells(12).Areas
                ar.EntireRow.Delete xlUp
            Next
            On Error GoTo 0
            .UsedRange.EntireRow.Hidden = 0
        End With
        .ScreenUpdating = 1: .EnableEvents = 1
    End With
End Sub