エクセル2007、右クリックメニューにシート一覧ボタンを作成するマクロ修正版

エクセル2007、右クリックメニューからシート一覧を表示してシートを選択 - 午後わてんのブログ - Yahoo!ブログ

http://blogs.yahoo.co.jp/gogowaten/11664697.html

gogowaten.hatenablog.com

↑2014/05/30は5ヶ月前の修正版

セルの右クリックメニューにシート一覧を選択するボタンを追加するマクロ

追加されたボタンはエクセルを終了すると自動で消える

f:id:gogowaten:20191015123915p:plain

修正した不具合は

他のブックで右クリックするとそのブックのシート一覧ボタンも作成されてしまう

というもの

↑はBook2で右クリックした後にもう一度右クリックしたところ

マクロを実行していないのにBook2のシート一覧ボタンをが作成されている

この不具合を修正したマクロが↓

シート一覧を作りたいウィンドウを開いた状態で

右クリックメニューにシート一覧新規作成

を実行

Public Sub 右クリックメニューにシート一覧新規作成() '2014/10/28

    Dim CB As CommandBar
    Dim b1 As CommandBarPopup
    Dim b2 As CommandBarButton
    Dim ws As Sheets
    Dim Wbn As String, b1Name As String
    Dim c As CommandBarControl, b As CommandBarControl
    
    Set ws = ActiveWorkbook.Sheets
    Set CB = Application.CommandBars(36) '右クリックメニュー
    Wbn = ActiveWorkbook.Name
    b1Name = Wbn & "シート一覧"
       
    Set b1 = CB.Controls.Add(Type:=msoControlPopup, temporary:=True, before:=1) ', parameter:=wbn)
    
    With b1
        .Caption = b1Name 'アクティブブック名 & "シート一覧"
        .OnAction = "右クリックメニューにシート一覧更新確認用"
        
        For i = 1 To ws.Count
            Set b2 = .Controls.Add(Type:=msoControlButton, temporary:=True, parameter:=Wbn)
            b2.Caption = ws(i).Name
            b2.OnAction = "シート選択"
        Next i
    End With
    
End Sub

Public Sub 右クリックメニューにシート一覧更新確認用() '2014/10/28

    Dim CB As CommandBar
    Dim b1 As CommandBarPopup
    Dim b2 As CommandBarButton
    Dim ws As Sheets
    Dim Wbn As String, b1Name As String
    Dim c As CommandBarControl, b As CommandBarControl
    
    Set ws = ActiveWorkbook.Sheets
    Set CB = Application.CommandBars(36) '右クリックメニュー
    Wbn = ActiveWorkbook.Name
    b1Name = Wbn & "シート一覧"
    
'右クリックメニューにシート一覧ボタンがあればその中のボタンを全部消去して新しくボタンを作りなおす
    For Each c In CB.Controls
        If c.Caption = b1Name Then 'ボタンのキャプションとアクティブブックの名前が一致
            Set b1 = c
            For Each b In c.Controls '全部消去
                b.Delete
            Next b
            
            '作り直し
            With b1
                .Caption = b1Name 'アクティブブック名 & "シート一覧"
                .OnAction = "右クリックメニューにシート一覧更新確認用"
                
                For i = 1 To ws.Count
                    Set b2 = .Controls.Add(Type:=msoControlButton, temporary:=True, parameter:=Wbn)
                    b2.Caption = ws(i).Name
                    b2.OnAction = "シート選択"
                Next i
            End With
            Exit Sub '全て終了
            
        End If
    Next c
        
End Sub

Public Sub シート選択() '2014/05/30

    'Application.CommandBars.ActionControl.Captionこれで押されたボタンのcaption取得できた
    'sName = Application.CommandBars.ActionControl.parameter 'ボタンにマクロく設定する時にparameterを設定していればその値を取得できる
'    Dim sName As String
'    sName = Application.CommandBars.ActionControl.Caption
    On Error Resume Next
    Dim AwCap As String, bName As String, aName As String
    Dim l As Long
    bName = Application.CommandBars.ActionControl.parameter '表示したいシートのブックの名前
    AwCap = ActiveWindow.Caption
    
    '同じブックで複数のウィンドウが開かれている場合はウィンドウ名に「:」が付いているのが目印になる
    l = InStr(ActiveWindow.Caption, ":") '「:」は何文字目？
    
    If l <> 0 Then
        aName = Left(AwCap, l - 1) '右クリックしたシートのブックの名前
    End If
    
    '目的のシートを表示する
    If bName <> aName Or l = 0 Then
        '表示したいシートとクリックしたシートのブックが違うor複数ウィンドウじゃない時
        Workbooks(bName).Activate
        ActiveWorkbook.Sheets(Application.CommandBars.ActionControl.Caption).Activate
    Else
        '表示したいシートとクリックしたシートのブックが同じで複数ウィンドウの時
        Windows(AwCap).Activate
        ActiveWorkbook.Sheets(Application.CommandBars.ActionControl.Caption).Activate
    End If

End Sub