Создание настраиваемого меню, которое вызывает макрос

В следующем примере кода показано, как создать пользовательское меню с четырьмя параметрами меню, каждое из которых вызывает макрос.

Пример кода предоставлен: издательством Holy Macro! Books, Holy Macro! It's 2,500 Excel VBA Examples (книга "2500 примеров VBA для Excel" от Holy Macro! на английском языке)

В следующем примере кода настраивается настраиваемое меню при открытии книги и удаляется при закрытии книги.

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   With Application.CommandBars("Worksheet Menu Bar")
      On Error Resume Next
      .Controls("&MyFunction").Delete
      On Error GoTo 0
   End With
End Sub

Private Sub Workbook_Open()
   Dim objPopUp As CommandBarPopup
   Dim objBtn As CommandBarButton
   With Application.CommandBars("Worksheet Menu Bar")
      On Error Resume Next
      .Controls("MyFunction").Delete
      On Error GoTo 0
      Set objPopUp = .Controls.Add( _
         Type:=msoControlPopup, _
         before:=.Controls.Count, _
         temporary:=True)
   End With
   objPopUp.Caption = "&MyFunction"
   Set objBtn = objPopUp.Controls.Add
   With objBtn
      .Caption = "Formula Entry"
      .OnAction = "Cbm_Active_Formula"
      .Style = msoButtonCaption
   End With
   Set objBtn = objPopUp.Controls.Add
   With objBtn
      .Caption = "Value Entry"
      .OnAction = "Cbm_Active_Value"
      .Style = msoButtonCaption
   End With
   Set objBtn = objPopUp.Controls.Add
   With objBtn
      .Caption = "Formula Selection"
      .OnAction = "Cbm_Formula_Select"
      .Style = msoButtonCaption
   End With
   Set objBtn = objPopUp.Controls.Add
   With objBtn
      .Caption = "Value Selection"
      .OnAction = "Cbm_Value_Select"
      .Style = msoButtonCaption
   End With
End Sub

Меню MyFunction добавляется при открытии книги и удаляется при закрытии книги. Он предоставляет четыре варианта меню с макросом, назначенным каждому параметру. Определяемая пользователем функция MyFunction умножает три значения в диапазоне и возвращает результат.

Function MyFunction(rng As Range) As Double
   MyFunction = rng(1) * rng(2) * rng(3)
End Function

Запись формулы: Этому параметру меню назначается макрос "Cbm_Active_Formula", который вызывает определяемую пользователем функцию "MyFunction", которая умножает числа в предыдущих трех ячейках и сохраняет значение определяемой пользователем функции в активной ячейке. Необходимо иметь значения в диапазоне B6:D6 и выбрать ячейку E6, прежде чем щелкнуть этот параметр меню.

Sub Cbm_Active_Formula()
   'setting up the variables.
   Dim intLen As Integer, strRng As String
   
   'Using the active cell, E6.
   With ActiveCell
      'Check to see if the preceding offset has valid data, and if there are three values
      If IsEmpty(.Offset(0, -1)) Or .Column < 4 Then
         
          'If the data is not valid, call MyFunction directly as a formula, but with no parameters.
         .Formula = "=MyFunction()"
          Application.SendKeys "{ENTER}"
      Else
      
         'If the data is valid, create a range of the preceding 3 cells
         strRng = Range(Cells(.Row, .Column - 3), _
            Cells(.Row, .Column - 1)).Address
         intLen = Len(strRng)
         
         'Call MyFunction as a formula, with the range as the parameter.
         .Formula = "=MyFunction(" & strRng & ")"
            Application.SendKeys "{ENTER}"
      End If
   End With
End Sub

Ввод значения: Этому параметру меню назначается макрос "Cbm_Active_Value", который вводит значение, созданное UDF с именем MyFunction, в активную ячейку. Необходимо иметь значения в диапазоне B6:D6 и выбрать ячейку E6, прежде чем щелкнуть этот параметр меню.

Sub Cbm_Active_Value()
   'Set up the variables.
   Dim intLen As Integer, strRng As String
   
   'Using the active cell, E6.
   With ActiveCell
      'If there isn't enough room in the column, then send a warning.
      If .Column < 4 Then
         Beep
         MsgBox "The function can be used only starting from column D!"
      
      'Otherwise, call MyFunction, using the range of the previous 3 cells.
      Else
         ActiveCell.Value = MyFunction(Range(ActiveCell.Offset(0, -3), _
            ActiveCell.Offset(0, -1)))
      End If
   End With
End Sub

Выбор формулы: Этому параметру меню назначается макрос "Cbm_Formula_Select", который использует inputBox для пользователя, чтобы выбрать диапазон, который должен вычислить UDF MyFunction. Возвращаемое значение UDF хранится в активной ячейке.

Sub Cbm_Formula_Select()
   'Set up the variables.
   Dim rng As Range
   
   'Use the InputBox dialog to set the range for MyFunction, with some simple error handling.
   Set rng = Application.InputBox("Range:", Type:=8)
   If rng.Cells.Count <> 3 Then
      MsgBox "Length, width and height are needed -" & _
         vbLf & "please select three cells!"
      Exit Sub
   End If
   'Call MyFunction in the active cell, E6.
   ActiveCell.Formula = "=MyFunction(" & rng.Address & ")"
End Sub

Выбор значения. Этому параметру меню назначается макрос "Cbm_Value_Select", в котором используется поле InputBox для выбора пользователем диапазона, который должен вычислить UDF MyFunction. Значение сохраняется непосредственно в активной ячейке, а не возвращается определяемым пользователем.

Sub Cbm_Value_Select()
   'Set up the variables.
   Dim rng As Range
   
   'Use the InputBox dialog to set the range for MyFunction, with some simple error handling.
   Set rng = Application.InputBox("Range:", Type:=8)
   If rng.Cells.Count <> 3 Then
     MsgBox "Length, width and height are needed -" & _
         vbLf & "please select three cells!"
      Exit Sub
   End If
   
   'Call MyFunction by value using the active cell, E6.
   ActiveCell.Value = MyFunction(rng)
End Sub

Об участнике

Издательство Holy Macro! Books публикует книги о работе с Microsoft Office в занимательном стиле. Полный каталог см. на веб-сайте MrExcel.com.

Поддержка и обратная связь

Есть вопросы или отзывы, касающиеся Office VBA или этой статьи? Руководство по другим способам получения поддержки и отправки отзывов см. в статье Поддержка Office VBA и обратная связь.