[vba]

Sub CreateMenu()
Dim MenuObject As CommandBarPopup, MenuItem As Object
Dim SubMenuItem As CommandBarButton, Sh As Worksheet, i As Long
' Make sure the menus aren't duplicated
Call DeleteMenu
' Add the top-level menu to the Worksheet CommandBar
Set MenuObject = Application.CommandBars(1). _
Controls.Add(Type:=msoControlPopup, Temporary:=True)
'Name of top level menu. Remember to also change caption in DeleteMenu macro
MenuObject.Caption = "&Navigate"
'Add 1st menu item
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
MenuItem.Caption = "Go To Sheet"
'Add sub menu items to 1st menu
For Each Sh In ThisWorkbook.Sheets
If Sh.Visible = xlSheetVisible Then
i = i + 1
Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)
SubMenuItem.Caption = Sh.Name
SubMenuItem.OnAction = "'LinkSheet(" & i & ")'"
If ActiveSheet.Name = Sh.Name Then SubMenuItem.FaceId = 1087
End If
Next Sh
End Sub
[/vba]