Sub Штрукт2()
Dim ТЧК As Range, Я As Range, n As Byte
Application.ScreenUpdating = False 'а то Excel'я корёжит :)
 Set ТЧК = Selection
 If ТЧК.Rows.Count = 1 Then
   For Each Я In ТЧК
     If Я Like ("[1-8]") Then n = Я Else n = 1
     Я.EntireColumn.OutlineLevel = n
   Next
 ElseIf ТЧК.Columns.Count = 1 Then
   For Each Я In ТЧК
     If Я Like ("[1-8]") Then n = Я Else n = 1
     Я.EntireRow.OutlineLevel = n
   Next
 Else
     MsgBox "А одну строку или один столбец выделить слабо?"
 End If
Application.ScreenUpdating = True
End Sub

Sub GrouperRows()
On Error GoTo ErrCl
NextHandler:
 Dim i As Integer
  i = InputBox("Выберите уровень группировки", "Уровень группировки", 1)
  ActiveSheet.Outline.ShowLevels RowLevels:=i
  Exit Sub
ErrCl:
 Result = MsgBox("Такого уровня нет. Выбрать другой? " & Chr(10) & _
 Err.Description, vbYesNo, "Ошибка")
 If Result = vbYes Then Resume NextHandler
End Sub