H = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count - 3 
    
    With Cells(1, 3)
        .FormulaR1C1 = "=ПРОМЕЖУТОЧНЫЕ.ИТОГИ(109;R[3]C:R[" & H & "]C)"
        .NumberFormat = "#,##0.00"
    End With

Dim popup As CommandBarControl
    Set popup = Add_Control(AddinMenu, ct_POPUP, 548, "", "Меню", , True)
    Add_Control popup, ct_BUTTON, None, "1", "Один", False
    Add_Control popup, ct_BUTTON, None, "2", "Два", False
дальше нужно подменю: 3, 4

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim WorkRange As Range, CrossRange As Range
        Set WorkRange = Range("A1:H36")    'адрес рабочего диапазона с таблицей
        If Target.Count > 1 Then
        WorkRange.FormatConditions.Delete
        Exit Sub
        End If
        Application.ScreenUpdating = False
        If Not Intersect(Target, WorkRange) Is Nothing Then
            Set CrossRange = Intersect(WorkRange, Union(Target.EntireRow, Target.EntireColumn))
            WorkRange.FormatConditions.Delete
            CrossRange.FormatConditions.Add Type:=xlExpression, Formula1:="=1"
            CrossRange.FormatConditions(1).Interior.ColorIndex = 15
            Target.FormatConditions.Delete
        End If
End Sub

Sub test()
    Dim rng As Range, i As Long
    With ActiveSheet
    Cells.UnMerge
    Set rng = Application.Intersect(Selection, .UsedRange)
    For i = rng.Columns.Count To 1 Step -1
        If Application.CountA(rng.Columns(i)) <= 1 Then rng.Columns(i).Delete
    Next i
    Selection.Columns.AutoFit
    End With
End Sub

arr(i, 1) = Application.Trim(Replace(arr(i, 1), "ссс ddd", "gggggg"))

#If Win64 Then
    #If VBA7 Then    ' Windows x64, Office 2010
       Private Declare PtrSafe Function GetTickCount Lib "Kernel32" () As LongLong
    #Else    ' Windows x64,Office 2003-2007
       Private Declare Function GetTickCount Lib "Kernel32" () As LongLong
    #End If
#Else
    #If VBA7 Then    ' Windows x86, Office 2010
       Private Declare PtrSafe Function GetTickCount Lib "Kernel32" () As Long
    #Else    ' Windows x86, Office 2003-2007
       Private Declare Function GetTickCount Lib "Kernel32" () As Long
    #End If
#End If

Cell.value = (Int(Cell.value / 6) - (Cell.value / 6 - Int(Cell.value / 6) > 0)) * 6