pop-up для 6062

'Это кидаем в Модуль
'Option Explicit
 
Sub AddToShortCut2()
'   Adds a menu item to the Cell shortcut menu (all open workbook windows)
    Dim NewControl As CommandBarButton
    Dim NewContro2 As CommandBarButton
    Dim NewContro3 As CommandBarButton
    Dim activeWin As Window
    Dim w As Window
 
    Set activeWin = ActiveWindow
    Application.ScreenUpdating = False
 
'   Loop through each visible window
    For Each w In Windows
        If w.Visible Then
            w.Activate
'           Delete control if it already exists
            On Error Resume Next
            CommandBars("Cell").Controls("Преобразовать606276").Delete
            CommandBars("Cell").Controls("Удалить все листы").Delete
            CommandBars("Cell").Controls("Удалить лишние пробелы").Delete
            On Error GoTo 0
'           Add the new control
Set NewControl = CommandBars("Cell").Controls.Add _
                (Type:=msoControlButton, ID:=1)
            With NewControl
                .Caption = "Преобразовать606276"
                .OnAction = "Преобразовать606276"
                .FaceId = 59
                .Style = msoButtonIconAndCaption
            End With
 
'Удалить листы
Set NewContro2 = CommandBars("Cell").Controls.Add _
                (Type:=msoControlButton, ID:=2)
    With NewContro2
        .Caption = "Удалить все листы"
        .OnAction = "УдалитьВсеЛисты"
        .FaceId = 478
        .Style = msoButtonIconAndCaption
    End With
 
' Удалить лишние пробелы
Set NewContro3 = CommandBars("Cell").Controls.Add _
                (Type:=msoControlButton, ID:=3)
    With NewContro3
        .Caption = "Удалить лишние пробелы"
        .OnAction = "TRIMinSelection"
        .FaceId = 384
        .Style = msoButtonIconAndCaption
    End With
 
 
        End If
    Next w
'   Activate original window
    activeWin.Activate
    Application.ScreenUpdating = True
End Sub
 
Sub ResetAllShortcutMenus()
'   Работает только в активном окне
    Dim cbar As CommandBar
    For Each cbar In Application.CommandBars
        If cbar.Type = msoBarTypePopup Then
            cbar.Reset
            cbar.Enabled = True
        End If
    Next cbar
End Sub


Sub УдалитьВсеЛисты()

Application.DisplayAlerts = False
   For Each s In ThisWorkbook.Sheets
       If s.Name  "Общая ОСВ" Then s.Delete
   Next s
Application.DisplayAlerts = False
End Sub

Sub TRIMinSelection()
    ' Удаляет лишние пробелы в выделенном диапазоне
    Dim rngRectangle As Range, rngRows As Range, rngColumns As Range
    Set rngRectangle = Selection
    ' Определяет вертикальный вектор массива
    Set rngRows = rngRectangle.Resize(, 1)
    ' Определяет горизонтальный вектор массива
    Set rngColumns = rngRectangle.Resize(1)
    rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "), IF(COLUMN(" & rngColumns.Address & "),TRIM(" & rngRectangle.Address & ")))")
End Sub