Option Explicit
Public Sub AddRightClickMenuOption()
Const sMenuText As String = "My Menu Option"
Const sMacroToRun As String = "My_Macro"
'Ignore error which occurs if menu item to be deleted does not exist
On Error Resume Next
'Delete menu item
CommandBars("Cell").Controls(sMenuText).Delete
'Reinstate default error handling
On Error GoTo 0
'Alternative method to delete menu item - no error handling required
Dim i As Integer
Dim cbarCtrl As CommandBarControl
For i = 1 To CommandBars("Cell").Controls.Count
Set cbarCtrl = CommandBars("Cell").Controls(i)
If cbarCtrl.Caption = sMenuText Then cbarCtrl.Delete
Next
'Add new menu item
With CommandBars("Cell").Controls.Add(msoControlButton, , , 1, True)
.Caption = sMenuText
.OnAction = sMacroToRun
.BeginGroup = True
End With
End Sub
Option Explicit
Public Sub My_Macro()
MsgBox "This is My_Macro"
End Sub
' This sub calls sub in sheet1 so that dynamic range is adjusted
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Application.EnableEvents = False
Call Sheet1.AddRightClickMenuOption
Application.EnableEvents = True
End Sub
Public Sub AddRightClickMenuOption()
Const sMenuText As String = "Projects"
Const sMacroToRun As String = "My_Macro"
'Ignore error which occurs if menu item to be deleted does not exist
On Error Resume Next
'Delete menu item
CommandBars("Cell").Controls(sMenuText).Delete
'Reinstate default error handling
On Error GoTo 0
'Add new menu item
Dim cLoop As Range
CommandBars("Cell").Controls.Add(msoControlPopup).Caption = sMenuText
With CommandBars("Cell").Controls(sMenuText)
'Add sub menu
For Each cLoop In Sheet2.Range("Projects").Cells
.Controls.Add(Type:=msoControlButton).Caption = cLoop.Cells.Value
Next
End With
End Sub
Option Explicit
Public Sub Reset_Cell_Menu()
Application.CommandBars("Cell").Reset
End Sub
Public Sub AddRightClickMenuOption2()
'Add a menu option and sub menu options to Excel's right-click cell menu
Const sMainMenuText As String = "Projects"
Dim sMacroToRun As String
Dim cbcMainMenu As CommandBarControl
Dim cbcSubMenu As CommandBarControl
Dim rCell As Range
Dim sAction As String
Dim sCellReference As String
'Ignore error which occurs if menu item about to be deleted does not exist
On Error Resume Next
'Delete existing menu item (if previously added)
CommandBars("Cell").Controls(sMainMenuText).Delete
'Reinstate default error handling
On Error GoTo 0
'Add new menu item as first item
Set cbcMainMenu = CommandBars("Cell").Controls.Add(msoControlPopup, Before:=1)
With cbcMainMenu
.Caption = sMainMenuText
'Add sub menu items from the Projects named range
For Each rCell In Range("Projects").Cells
Set cbcSubMenu = .Controls.Add(msoControlButton)
With cbcSubMenu
.Caption = rCell.Value
'My_Macro()
'sMacroToRun = "My_Macro"
'sAction = "'" & sMacroToRun & "'"
'My_Macro_With_Params(sProjectName As String)
'sMacroToRun = "My_Macro_With_Params"
'sAction = "'" & sMacroToRun & " " & _
' """" & rCell.Value & """" & _
' "'"
'My_Macro_With_Params2(sProjectName As String, sCellReference As String)
'sMacroToRun = "My_Macro_With_Params2"
'sCellReference = rCell.Worksheet.Name & "!" & rCell.Address
'sAction = "'" & sMacroToRun & " " & _
' """" & rCell.Value & """" & ", " & _
' """" & sCellReference & """" & _
' "'"
'My_Macro_With_Params3(sProjectName As String, sSheet as String, iRow As Integer, iCol As Integer)
sMacroToRun = "My_Macro_With_Params3"
sAction = "'" & sMacroToRun & " " & _
"""" & rCell.Value & """" & ", " & _
"""" & rCell.Worksheet.Name & """" & ", " & _
rCell.Row & ", " & _
rCell.Column & _
"'"
MsgBox "OnAction = " & sAction
.OnAction = sAction
End With
Next
End With
End Sub
Public Sub My_Macro()
MsgBox "This is My_Macro"
End Sub
Public Sub My_Macro_With_Params(sProjectName As String)
MsgBox "This is My_Macro_With_Params" & vbNewLine & _
"Project name = " & sProjectName
End Sub
Public Sub My_Macro_With_Params2(sProjectName As String, sCellReference As String)
MsgBox "This is My_Macro_With_Params2" & vbNewLine & _
"Project name = " & sProjectName & vbNewLine & _
"Cell reference = " & sCellReference
End Sub
Public Sub My_Macro_With_Params3(sProjectName As String, sSheet As String, iRow As Integer, iCol As Integer)
MsgBox "This is My_Macro_With_Params3" & vbNewLine & _
"Project name = " & sProjectName & vbNewLine & _
"Sheet = " & sSheet & vbNewLine & _
"Row = " & iRow & vbNewLine & _
"Column = " & iCol
End Sub
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Application.EnableEvents = False
Call Sheet1.AddRightClickMenuOption
Application.EnableEvents = True
End Sub