Attribute VB_Name = "Module1"
'■　マクロ５００連発＜第２段＞
'
'　メニュー項目がクリックされた時にサブメニュー項目の内容を更新する
'
'  Copyright(C) 2000 Sunago
'
'  　Macro1を実行するとWorksheet Menu Barに拡張メニュー」項目を
'  追加し、サブメニューにアクティブブックのシート名を追加します。
'  　このマクロの動作は、「拡張メニュー」がクリックされた時点で、
'  "Macro1Sub"を呼び出され、サブメニューの内容を更新しています。
'  Macro1実行後、シートを追加、削除してサブメニューの項目を
'  ご確認ください。
'
Option Explicit

'/* メニュークリック時にサブメニュー項目を更新する */

Const CMNUBAR = "Worksheet Menu Bar"
Const CMNUEXT = "拡張メニュー"

Sub Macro1()
Dim mnuPopup As CommandBarControl
Dim mnuButton As CommandBarControl
Dim objSheet As Object

    With Application.CommandBars(CMNUBAR)
        Set mnuPopup = .Controls.Add _
                        (Type:=msoControlPopup)
        With mnuPopup
            .Caption = CMNUEXT
            .OnAction = "Macro1Sub"
            'サブメニューにシート名を追加する
            For Each objSheet In ActiveWorkbook.Sheets
                Set mnuButton = .Controls.Add _
                                (Type:=msoControlButton)
                With mnuButton
                    .Caption = objSheet.Name
                    .OnAction = "Macro2"
                    .Parameter = .Caption
                End With
            Next
        End With
        Set mnuButton = Nothing
        Set mnuPopup = Nothing
    End With
End Sub

Private Sub Macro1Sub()
'サブメニュー項目を追加、削除する
'
'■このプロシージャを修正する上での注意事項
'
'　　このプロシージャ内でMsgBox等のダイアログを表示すると
'　サブメニューが表示できなくなる。そのため、エラーが発生
'  する場合を除き、そのような処理を記述しないのが望ましい。

Dim mnuButton
Dim objSheet As Object
Dim i As Long
Dim j As Long
    
    With Application.CommandBars(CMNUBAR).Controls(CMNUEXT)
        i = 0
        Set mnuButton = Nothing
        For Each objSheet In ActiveWorkbook.Sheets
            i = i + 1
            On Error Resume Next
            Set mnuButton = .Controls(objSheet.Name)
            On Error GoTo 0
            If mnuButton Is Nothing Then
            '同名のメニュー項目がなければ、新しい項目を追加する
                Set mnuButton = .Controls.Add _
                                (Type:=msoControlButton, Before:=i)
                With mnuButton
                    .Caption = objSheet.Name
                    .OnAction = "Macro2"
                    .Parameter = .Caption
                End With
            ElseIf i <> mnuButton.Index Then
            'シート番号とメニュー項目の位置が異なる時は、項目を移動する
                mnuButton.Move Before:=i
            End If
            Set mnuButton = Nothing
        Next
        If i < .Controls.Count Then
            For j = i + 1 To .Controls.Count
                .Controls(j).Delete
            Next
        End If
    End With
End Sub

Private Sub Macro2()
'Buttonメニュー項目から呼び出されるプロシージャ
Dim a

    a = Application.Caller
    With Application.CommandBars(CMNUBAR).Controls(CMNUEXT)
        Sheets(.Controls(a(1)).Parameter).Activate
    End With
End Sub

Sub Macro1Reset()
'Worksheet Menu Bar を初期状態にする
    Application.CommandBars("Worksheet Menu Bar").Reset
End Sub