Группировка строк в Excel (макрос)

Sub Macro1()
 
    Range("A2:C5").Select 'tkan', vid tkani, kol-vo
    Selection.Rows.Group
    Range("A7:C9").Select 'Kamen', nazvanie kamnya, kol-vo
    Selection.Rows.Group
 
End Sub

Sub Группировка()
  ' вначале выдели строки для массовой группировки
  x = 1 ' номер колонки
  Dim rng As Range
  Set rng = Selection.EntireRow
  y = rng.Row
  yend = y + rng.Rows.Count - 1
  mes = "Выполнить массовую группировку" & vbCr & _
      "со строки " & y & " по строку " & yend & "?"
  If MsgBox(mes, vbQuestion + vbOKCancel, "") = vbCancel Then End
  ybeg = y
  ActiveSheet.Outline.SummaryRow = xlAbove
  For y = y To yend
    If Cells(y, x) <> Cells(y + 1, x) _
    Or y = yend Then
      If ybeg + 1 <= y Then Rows(ybeg + 1 & ":" & y).Rows.Group
      ybeg = y + 1
    End If
  Next
  MsgBox "Готово", vbInformation, ""
End Sub

Option Explicit
Sub grp() 'Группировка
 On Error GoTo errH
 Dim h: Set h = New Scripting.dictionary
 Dim x As Range
 Set x = Selection.EntireColumn.Cells.SpecialCells(xlCellTypeConstants)
    Dim i As Long, j As Long, c As Range
    For i = 1 To 10
      For Each c In x.Cells
         c.Select
         For j = i To 10
            DoEvents
            If c.Value = j Then
                 If IsEmpty(h(i)) Then
                    Set h(i) = c
                 Else
                    Set h(i) = Union(h(i), c)
                 End If
            End If
         Next j
      Next c
    Next i
 Dim k
 Dim a As Range
 For Each k In h.Keys
  For Each a In h(k).Areas
   DoEvents
   a.Rows.Group
  Next a
 Next k
 If 0 Then
errH:
   MsgBox Err.Description
 End If
 Set h = Nothing
End Sub
Sub ugp() 'Разгруппировка
On Error Resume Next
   Rows.Ungroup
   Rows.Ungroup
   Rows.Ungroup
   Rows.Ungroup
   Rows.Ungroup
   Rows.Ungroup
   Rows.Ungroup
   Rows.Ungroup
End Sub