Sub Макрос2()
Dim arr1 As Variant, n As Long, r As Long, m As Long, s1 As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
r = Cells(Rows.Count, 4).End(xlUp).Row
arr1 = Range("A6:I" & r)
Set al = CreateObject("System.Collections.ArrayList")
For n = 1 To UBound(arr1)
    If Not arr1(n, 2) = "" Then 'And Not arr1(n, 3) = "" Then
        s1 = arr1(n, 2) & arr1(n, 3)
        arr1(n, 9) = s1
        al.Add s1
    Else
        arr1(n, 9) = s1 & arr1(n, 4) & arr1(n, 5)
        al.Add s1 & arr1(n, 4) & arr1(n, 5)
    End If
Next
al.Sort
For n = 1 To UBound(arr1)
    For m = 1 To UBound(arr1)
        If arr1(m, 9) = al.Item(n - 1) Then
            Rows(r + n + 1 & ":" & r + n + 1).Insert Shift:=xlDown
            Rows(m + 5 & ":" & m + 5).Cut Destination:=Rows(r + n & ":" & r + n)
            arr1(m, 9) = ""
            Exit For
        End If
    Next m
Next n
Rows("6:" & r).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Sub Макрос3()
Dim arr1 As Variant, n As Long, r As Long, m As Long, i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
r = Cells(Rows.Count, 4).End(xlUp).Row
arr1 = Range("B6:C" & r)
ReDim Preserve arr1(LBound(arr1) To UBound(arr1), 1 To 4)
Set al = CreateObject("System.Collections.ArrayList")
For n = 1 To UBound(arr1)
    If Not arr1(n, 1) = "" Then 'And Not arr1(n, 3) = "" Then
        arr1(n, 4) = arr1(n, 1) & arr1(n, 2)
        al.Add arr1(n, 1) & arr1(n, 2)
        If Not al.Count = 1 Then arr1(n - i - 1, 3) = i
        i = 0
    Else
    i = i + 1
    End If
Next
arr1(n - i - 1, 3) = i
al.Sort
i = r + 1
For n = 1 To al.Count
    For m = 1 To UBound(arr1)
        If arr1(m, 4) = al.Item(n - 1) Then
            Rows(i & ":" & i + arr1(m, 3)).Insert Shift:=xlDown
            Rows(m + 5 & ":" & m + 5 + arr1(m, 3)).Cut Destination:=Rows(i & ":" & i + arr1(m, 3))
            i = i + arr1(m, 3) + 1
            arr1(m, 3) = "": arr1(m, 4) = ""
            Exit For
        End If
    Next m
Next n
Rows("6:" & r).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub


Sub Макрос3()
Dim arr1 As Variant, n As Long, r As Long, m As Long, i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
r = Cells(Rows.Count, 4).End(xlUp).Row
arr1 = Range("B6:C" & r)
ReDim Preserve arr1(LBound(arr1) To UBound(arr1), 1 To 4)
Set al = CreateObject("System.Collections.ArrayList")
For n = 1 To UBound(arr1)
    If Not arr1(n, 1) = "" Then 'And Not arr1(n, 3) = "" Then
        arr1(n, 4) = arr1(n, 1) & arr1(n, 2)
        al.Add arr1(n, 1) & arr1(n, 2)
        If Not al.Count = 1 Then arr1(n - i - 1, 3) = i
        i = 0
    Else
    i = i + 1
    End If
Next
arr1(n - i - 1, 3) = i
al.Sort
i = r + 1
For n = 1 To al.Count
    For m = 1 To UBound(arr1)
        If arr1(m, 4) = al.Item(n - 1) Then
            Rows(i & ":" & i + arr1(m, 3)).Insert Shift:=xlDown
            Rows(m + 5 & ":" & m + 5 + arr1(m, 3)).Cut Destination:=Rows(i & ":" & i + arr1(m, 3))
            i = i + arr1(m, 3) + 1
            arr1(m, 3) = "": arr1(m, 4) = ""
            Exit For
        End If
    Next m
Next n
Rows("6:" & r).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub