Excelの右クリックメニューに自家製マクロを追加する

これは

Excelに自分用の右クリックメニューを追加するための仕掛け。

準備

新規ブックに以下のコードを追加し、ブックをアドインとして保存します。
説明はおいおい追加します。（たぶん）

---

ThisWorkbook.cls

'ThisWorkbook.cls
Option Explicit

Const MY_KEY As String = "{F1},%s"

Private Sub Workbook_Open()
    Dim k
    For Each k In Split(MY_KEY, ",")
        Application.OnKey k, "ThisWorkbook.MenuPopup"
    Next
    Dim b As CommandBar
    With New myMenu
        For Each b In .Bars
            If b.Name Like "*Cell" Or b.Name Like "*Range*Popup*" Then .SetMenu b.Index
        Next
    End With
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim k
    For Each k In Split(MY_KEY, ",")
        Application.OnKey k
    Next
End Sub

Sub MenuPopup()
    With New myMenu
        .MenuPopup
    End With
End Sub

Sub MenuReset()
    On Error Resume Next
    Dim b As CommandBar
    For Each b In Application.CommandBars
        If b.BuiltIn Then
            b.Reset
        Else
            b.Delete
        End If
    Next
End Sub

Sub MenuReBuild()
    MenuReset
    Workbook_Open
End Sub

MyMenu.cls （クラスモジュール）

'MyMenu.cls （クラスモジュール）
Option Explicit

Const MY_NAME = "MyBar"
Dim cb As CommandBar

Property Get Bars() As CommandBars
    Set Bars = Application.CommandBars
End Property

Sub SetMenu(i)
    For Each cb In Bars
        If cb.Index = i Or cb.Name = i Then AddMenu: Exit Sub
    Next
    Set cb = Bars.Add(i, msoBarPopup): AddMenu
End Sub

Sub MenuPopup()
    cb.ShowPopup
End Sub

Private Sub Class_Initialize()
    SetMenu MY_NAME
End Sub

Private Sub AddMenu()
    On Error Resume Next
    Dim ws As Worksheet, dic As New Dictionary, i, procName, buf
    For Each ws In ThisWorkbook.Worksheets
        With ThisWorkbook.VBProject.VBComponents(ws.CodeName).CodeModule
            For i = 1 To .CountOfLines
                procName = .ProcOfLine(i, 0)
                If procName = "" Or dic.Exists(procName) Then
                Else
                    dic.Add procName, procName
                    buf = Trim(.Lines(i, .ProcCountLines(procName, 0)))
                    If Err.Number > 0 Then
                        Err.Clear
                    Else
                        If InStr(buf, "Private") = 0 Then
                            AddControl ws.CodeName, procName
                        End If
                    End If
                End If
            Next
            dic.RemoveAll
        End With
    Next
End Sub

Private Sub AddControl(pName, cName, Optional FaceId = 0)
    Dim c As CommandBarControl
    With Popup(pName)
        For Each c In .Controls
            If c.Caption = cName Then Exit For
        Next
        If c Is Nothing Then Set c = .Controls.Add
        c.Caption = cName
        c.OnAction = Join(Array(pName, cName), ".")
        c.FaceId = FaceId
    End With
End Sub

Private Function Popup(Caption) As CommandBarPopup
    Dim c As CommandBarControl
    With cb
        For Each c In .Controls
            If c.Caption = Caption Then Exit For
        Next
        If c Is Nothing Then Set c = .Controls.Add(msoControlPopup)
        c.Caption = Caption
        Set Popup = c
    End With
End Function

Sheet1.cls （ワークシート）

'Sheet1.cls （ワークシート）
Option Explicit

Sub メニュー再設定()
    ThisWorkbook.MenuReBuild
    ThisWorkbook.Save
End Sub

Sub 定番の参照設定を追加()
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    If MsgBox("定番の参照設定を追加", vbOKCancel, wb.Name) = vbCancel Then Exit Sub
    On Error Resume Next
    Dim e, refs As New Collection
    With refs
        .Add "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA7.1\VBE7.DLL"
        .Add "C:\Program Files (x86)\Microsoft Office\Root\Office16\EXCEL.EXE"
        .Add "C:\Windows\SysWOW64\stdole2.tlb"
        .Add "C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE16\MSO.DLL"
        .Add "C:\Program Files (x86)\Microsoft Office\Root\Office16\MSBCODE9.OCX"
        .Add "C:\Program Files (x86)\Common Files\System\ado\msado15.dll"
        .Add "C:\Windows\SysWOW64\ieframe.dll"
        .Add "C:\Program Files (x86)\Microsoft Office\Root\Office16\MSPPT.OLB"
        .Add "C:\Windows\SysWOW64\scrrun.dll"
        .Add "C:\Windows\SysWOW64\vbscript.dll\3"
        .Add "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
        .Add "C:\Windows\SysWOW64\wbem\wbemdisp.TLB"
        .Add "C:\Windows\SysWOW64\wshom.ocx"
    End With
    For Each e In refs
        wb.VBProject.References.AddFromFile e
    Next

    Dim dic As New Dictionary, ref As Reference
    For Each ref In wb.VBProject.References
        If Not ref.BuiltIn Then dic.Add ref.FullPath, Array(ref.GUID, ref.Major, ref.Minor)
    Next
    MsgBox Join(dic.Keys, vbLf)
End Sub


Sub 方眼()
    With ActiveCell.Worksheet.Cells
        .ColumnWidth = 2
        .RowHeight = 18.75
        .NumberFormatLocal = "@"
    End With
    With ActiveWindow
        .DisplayGridlines = False
    End With
End Sub

Sub 画面っぽく()
    With ActiveWindow.RangeSelection
        .BorderAround xlContinuous
        With .Resize(1)
            .Borders(xlEdgeBottom).LineStyle = xlDouble
            .Interior.ThemeColor = xlThemeColorAccent1
            .Interior.TintAndShade = 0.5
        End With
    End With
End Sub

Sub ボタンっぽく()
    With ActiveWindow.RangeSelection
        .Merge
        .HorizontalAlignment = xlCenter
        .BorderAround xlContinuous
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeRight).Weight = xlMedium
        With .Interior
            .Pattern = xlPatternLinearGradient
            .Gradient.Degree = 45
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -0.25
        End With
    End With
End Sub

補足

おかしなところがあったら教えてください。
Windows10 Home / Office 365 Businessの環境でしか確認していません。
いくつか参照設定をセットしています。