ExecuteExcel4Macro SHOW.DETAIL(...)

    Selection.Rows.Group
    Rows(ActiveCell.Row).ShowDetail = False

Option Explicit

Sub Группы()
Dim str As String, addr As String, addrend As String, curCell As Long, rng As Range

Application.FindFormat.Clear
'Application.FindFormat.NumberFormat = ActiveCell.NumberFormat
'    With Application.FindFormat
'        .HorizontalAlignment = ActiveCell.HorizontalAlignment  'xlGeneral
'        .VerticalAlignment = ActiveCell.VerticalAlignment  'xlTop
'        .WrapText = ActiveCell.WrapText  'True
'        .Orientation = ActiveCell.Orientation  '0
'        .AddIndent = ActiveCell.AddIndent  'False
'        .ShrinkToFit = ActiveCell.ShrinkToFit  'False
'        .MergeCells = ActiveCell.MergeCells  'False
'    End With
With Application.FindFormat.Font
  .Name = ActiveCell.Font.Name  '"Arial"
  .FontStyle = ActiveCell.Font.FontStyle  '"полужирный"
  .Size = ActiveCell.Font.Size  '11
'        .Strikethrough = ActiveCell.Font.Strikethrough  'False
'        .Superscript = ActiveCell.Font.Superscript  'False
'        .Subscript = ActiveCell.Font.Subscript  'False
'        .Underline = ActiveCell.Font.Underline  'xlUnderlineStyleNone
  .ColorIndex =  1 
End With
'    Application.FindFormat.Borders(xlLeft).LineStyle = ActiveCell.Borders(xlLeft).LineStyle  'xlNone
'    Application.FindFormat.Borders(xlRight).LineStyle = ActiveCell.Borders(xlRight).LineStyle 'xlNone
'    With Application.FindFormat.Borders(xlTop)
'        .LineStyle = ActiveCell.Borders(xlTop).LineStyle 'xlContinuous
'        .Weight = ActiveCell.Borders(xlTop).Weight  'xlThin
'        .ColorIndex = ActiveCell.Borders(xlTop).ColorIndex  'xlAutomatic
'    End With
'    With Application.FindFormat.Borders(xlBottom)
'        .LineStyle = ActiveCell.Borders(xlBottom).LineStyle  'xlContinuous
'        .Weight = ActiveCell.Borders(xlBottom).Weight  'xlThin
'        .ColorIndex = ActiveCell.Borders(xlBottom).ColorIndex  'xlAutomatic
'    End With
'    Application.FindFormat.Borders(xlDiagonalDown).LineStyle = ActiveCell.Borders(xlBottom).LineStyle  'xlNone
'    Application.FindFormat.Borders(xlDiagonalUp).LineStyle = ActiveCell.Borders(xlBottom).LineStyle  'xlNone
With Application.FindFormat.Interior
  .ColorIndex = ActiveCell.Interior.ColorIndex  '54
'        .Pattern = ActiveCell.Interior.Pattern  'xlSolid
'        .PatternColorIndex = ActiveCell.Interior.PatternColorIndex  'xlAutomatic
End With
'    Application.FindFormat.Locked = True
'    Application.FindFormat.FormulaHidden = False

On Error GoTo l1

str = ActiveSheet.UsedRange.AddressLocal
addrend = Mid(str, InStrRev(str, "$") +  1 )
addr = ActiveCell.Row
Cells.Find("", ActiveCell, xlFormulas, xlPart, xlByColumns, xlNext, False, , True).Activate

Application.ScreenUpdating = False

Do
  Set rng = ActiveCell

  curCell = ActiveCell.Row -  1 

  If ActiveCell.Row > addr Then
    Rows(CStr(addr +  1  & ":" & ActiveCell.Row -  1 )).Select
    Selection.Rows.Group
    Rows(ActiveCell.Row).ShowDetail = False
    'str = "SHOW.DETAIL(" & CStr(addr) & "," & CStr(curCell) & ",False,," & CStr(addr) - 1 & ")"

    'ExecuteExcel4Macro str
  End If
  addr = curCell +  1 
  
  rng.Select
  Cells.Find("", ActiveCell, xlFormulas, xlPart, xlByColumns, xlNext, False, , True).Activate
  'Cells.FindNext(ActiveCell).Activate
Loop While ActiveCell.Row > curCell
    
Rows(CStr(addr +  1  & ":" & addrend -  1 )).Select
Selection.Rows.Group
Rows(ActiveCell.Row).ShowDetail = False
Application.ScreenUpdating = True

Set rng = Nothing
    
Exit Sub
    
l1:
If Err.Number =  91  Then MsgBox "Не выделена ячейка с искомым форматом"

End Sub
_______________________________________________________________________________
Public Sub Меню()
Dim MyBar As CommandBar, MyButton( 0 ) As CommandBarButton

On Error GoTo l1

Set MyBar = Application.CommandBars.Add("Группа", msoBarTop, False, True)

With MyBar.Controls
   Set MyButton( 0 ) = .Add(msoControlButton,  1 , , , True)
End With
With MyButton( 0 )
   .FaceId =  3987 
   .Caption = "Скрыть"
   .TooltipText = "Группировать и свернуть группы"
   .Style = msoButtonIconAndCaption
   .OnAction = "Группы"
End With

Set MyBar = CommandBars("Группа")

MyBar.Visible = True

Exit Sub

l1:
CommandBars("Группа").Delete
Resume

End Sub

Private Sub Workbook_Open()
Call Группа.Меню
End Sub