Crear un menú personalizado que llame a una macro

El ejemplo de código siguiente muestra cómo crear un menú personalizado con cuatro opciones de menú, cada una de las cuales llama a una macro.

Código de ejemplo proporcionado por: Holy Macro! Books,Holy Macro! It's 2,500 Excel VBA Examples (Holy Macro! 2500 ejemplos de VBA para Excel).

En el ejemplo de código siguiente se configura el menú personalizado cuando se abre el libro y se elimina cuando se cierra el libro.

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

El menú "MyFunction" se agrega cuando se abre el libro y se elimina cuando se cierra el libro. Proporciona cuatro opciones de menú y hay una macro asignada a cada opción. La función definida por el usuario (UDF) "MyFunction" multiplica tres valores de un rango y devuelve el resultado.

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

Introducción de fórmulas: esta opción de menú se asigna a la macro "Cbm_Active_Formula", que llama a la UDF denominada "MyFunction", la cual multiplica los números que hay en las tres celdas anteriores y almacena el valor de la UDF en la celda activa. Debe haber valores en el rango B6:D6 y tenemos que seleccionar la celda E6 antes de hacer clic en esta opción de menú.

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 valores: esta opción de menú se asigna a la macro "Cbm_Active_Value", que introduce en la celda activa el valor que genera la UDF denominada "MyFunction". Debe haber valores en el rango B6:D6 y tenemos que seleccionar la celda E6 antes de hacer clic en esta opción de menú.

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

Selección de fórmulas: esta opción de menú se asigna a la macro "Cbm_Formula_Select", que usa un CuadroEntr para que el usuario seleccione el rango que debe calcular la UDF "MyFunction". El valor devuelto de la UDF se almacena en la celda activa.

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

Selección de valores: esta opción de menú se asigna a la macro "Cbm_Value_Select", que usa un CuadroEntr para que el usuario seleccione el rango que debe calcular la UDF "MyFunction". El valor se almacena en la celda activa directamente, es decir, no lo devuelve la 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

Acerca del colaborador

Holy Macro! Books publica libros amenos para los usuarios de Microsoft Office. Vea el catálogo completo en MrExcel.com.

Soporte técnico y comentarios

¿Tiene preguntas o comentarios sobre VBA para Office o esta documentación? Vea Soporte técnico y comentarios sobre VBA para Office para obtener ayuda sobre las formas en las que puede recibir soporte técnico y enviar comentarios.