Criar um menu personalizado que chama uma macro

O exemplo de código a seguir mostra como criar um menu personalizado com quatro opções de menu, em que cada uma delas chama uma macro.

Código de exemplo fornecido por: Holy Macro! Livros, Holy Macro! É 2,500 exemplos do VBA Excel VBA

O exemplo de código a seguir define o menu personalizado quando a pasta de trabalho é aberta e o exclui quando a pasta de trabalho é fechada.

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

O menu "MyFunction" é adicionado quando a pasta de trabalho é aberta e excluído quando a pasta de trabalho é fechada. Ele fornece quatro opções de menu, com uma macro atribuída a cada opção. A UDF (função definida pelo usuário) "MyFunction" multiplica três valores em um intervalo e retorna o resultado.

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

Entrada de fórmula: Essa opção de menu é atribuída à macro "Cbm_Active_Formula", que chama a UDF nomeada "MyFunction" que, por sua vez, multiplica os números nas três células anteriores e armazena o valor da UDF na célula ativa. É necessário ter valores no intervalo B6:D6 e selecionar a célula E6 antes de clicar nessa opção de menu.

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

Entrada de valor: Essa opção de menu é atribuída à macro "Cbm_Active_Value", que insere o valor produzido pela UDF chamada "MyFunction" na célula ativa. É necessário ter valores no intervalo B6:D6 e selecionar a célula E6 antes de clicar nessa opção de menu.

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

Seleção de fórmula: Essa opção de menu é atribuída à macro "Cbm_Formula_Select", que usa uma InputBox para o usuário, a fim de selecionar o intervalo que a UDF "MyFunction" deverá calcular. O valor retornado da UDF será armazenado na célula ativa.

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

Seleção de valor: Essa opção de menu é atribuída à macro "Cbm_Value_Select", que usa uma InputBox para o usuário, a fim de selecionar o intervalo que a UDF "MyFunction" deverá calcular. O valor é armazenado na célula ativa diretamente, em vez de ser retornado pela UDF.

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

Sobre o colaborador

A Holy Macro! Books publica livros divertidos para pessoas que usam o Microsoft Office. Consulte o catálogo concluído em MrExcel.com.

Suporte e comentários

Tem dúvidas ou quer enviar comentários sobre o VBA para Office ou sobre esta documentação? Confira Suporte e comentários sobre o VBA para Office a fim de obter orientação sobre as maneiras pelas quais você pode receber suporte e fornecer comentários.