Sub uuu()
    Dim a()
    Dim i&, j&, rw&, gr&
    Dim cat$
'--------------------------
    Application.ScreenUpdating = False
    a = Sheets("Лист1").UsedRange.Value
    With Sheets("Лист2")
        .UsedRange.ClearOutline
        .Outline.SummaryRow = xlAbove
        rw = 2
        For i = 2 To UBound(a)
            cat = a(i, 1)
            .Cells(rw, 1) = cat
            gr = rw + 1
            Do
                DoEvents
                If a(i, 1) <> cat Then Exit Do
                rw = rw + 1
                For j = 2 To UBound(a, 2)
                    .Cells(rw, j) = a(i, j)
                Next
                i = i + 1
                If i > UBound(a) Then Exit Do
            Loop            
            .Rows(gr & ":" & rw).Group
            rw = rw + 1
            i = i - 1
        Next
        .Outline.ShowLevels RowLevels:=1
        .Activate
    End With
    Application.ScreenUpdating = True
    Beep
    MsgBox "Готово!"
End Sub