VBAの勉強を始めてみた

タイトルの通りVBAの勉強を始めました。効率化と暇つぶしを兼ねています。ブログの書き方なんて知りません分かりません。

右クリックショートカットメニューにマクロを登録

f:id:kouten0430:20170615151507j:plain

こんな感じで、右クリックした時のショートカットメニューにマクロを登録できたらいいなと思ったので、下記のようなマクロを作ってみました。対話形式で好きなマクロを右クリックのショートカットメニューに登録することができます。失敗してもリセットし、初期状態に戻せるようになっているので怖がらずに試してみて下さい。このマクロのカラクリについては後日改めて記載してみたいと思います。

使用する前に以下の点に目を通していただけると幸いです。
・単一のセルまたはセル範囲を選択している状態で右クリックした時のメニューを追加できます。
・列または行を選択している時の右クリックメニューには追加されません。
・特別な設定等をされているBook(Sheet)では使用できない場合があります。
・ショートカットメニューに登録するマクロは「個人用マクロブック」にあるといつでも呼び出せるので便利です。
・メニューやサブメニューを削除する際、存在しない名称を記入したり、名称を間違えるとエラーとなります。
・サブメニューを作成する際、上位階層のメニュー名に存在しない名称を記入したり、名称を間違えるとエラーとなります。
・登録するマクロ名は、Sub マクロ1 ()の「マクロ1」の部分を入力して下さい。
・マクロ名を間違えたり、存在しないマクロ名を入力すると、メニューからマクロを起動する際にエラーになります。
・マクロ名を間違えた場合は、該当のメニューまたはサブメニューを削除して再度追加し直して下さい。
・サブメニューを作成できるのは第二階層までです。第三階層以降の作成には対応していません。
・下記のマクロは保存しなくても、追加したショートカットメニューが消えることはありません。追加、削除、リセットはマクロからのみ行えます。


***************************************
Sub 右クリックショートカットメニューにマクロを登録()
    'このマクロ自体をメニューまたはサブメニューから呼び出している場合は、該当のメニューまたはサブメニューの削除はできません
   
    Dim sn As Variant
    Dim ct As Variant
    Dim bf As Variant
    Dim oa As Variant
    Dim bg As Variant
    Dim cts As Variant
    Dim myButton As CommandBarButton
    Dim myPopup As CommandBarPopup
   
    sn = Application.InputBox(Prompt:="処理内容を選択して下さい" & vbCrLf & "1:メニューの追加" & _
    vbCrLf & "2:サブメニューを含むメニューの追加" & vbCrLf & "3:サブメニューの追加" & vbCrLf & _
    "4:メニューの削除" & vbCrLf & "5:サブメニューの削除" & vbCrLf & "6:初期状態に戻す(リセット)", Type:=1)
        Select Case sn
       
        Case 1
ctr:
            ct = Application.InputBox(Prompt:="メニュー名を入力して下さい", Type:=2)
                If TypeName(ct) = "Boolean" Then
                    Exit Sub
                ElseIf ct = "" Then
                    GoTo ctr
                End If
oar:
            oa = Application.InputBox(Prompt:="メニューに登録するマクロ名を入力して下さい", Type:=2)
                If TypeName(oa) = "Boolean" Then
                    Exit Sub
                ElseIf oa = "" Then
                    GoTo oar
                End If
bfr:
            bf = Application.InputBox(Prompt:="メニューを上から何番目に配置しますか?(0で末尾)", Type:=1)
                If TypeName(bf) = "Boolean" Then
                    Exit Sub
                ElseIf bf = 0 Then
                    Set myButton = CommandBars("Cell").Controls.Add
                ElseIf bf >= 1 And bf <= CommandBars("Cell").Controls.Count Then
                    Set myButton = CommandBars("Cell").Controls.Add(Before:=bf) 'Before:=で配置位置を指定する。省略で末尾に配置
                Else
                    MsgBox "0~" & CommandBars("Cell").Controls.Count & "の数値で入力して下さい"
                    GoTo bfr
                End If
            myButton.Caption = ct '追加するメニュー名を入力
            myButton.OnAction = oa    '実行するマクロ名を入力
bgr:
            bg = Application.InputBox(Prompt:="メニューの上側に区切り線を入れますか?" & vbCrLf & _
            "1:入れる" & vbCrLf & "2:入れない", Type:=1)
                If TypeName(bg) = "Boolean" Then
                    Exit Sub
                ElseIf bg = 1 Then
                    myButton.BeginGroup = True  'Trueで上側に区切り線が表示される。Falseで区切り線なし
                ElseIf bg = 2 Then
                    myButton.BeginGroup = False
                Else
                    MsgBox "1または2を入力して下さい!"
                    GoTo bgr
                End If
               
        Case 2
ctrr:
            ct = Application.InputBox(Prompt:="サブメニューを含むメニュー名を入力して下さい", Type:=2)
                If TypeName(ct) = "Boolean" Then
                    Exit Sub
                ElseIf ct = "" Then
                    GoTo ctrr
                End If
bfrr:
            bf = Application.InputBox(Prompt:="サブメニューを含むメニューを上から何番目に配置しますか?(0で末尾)", Type:=1)
                If TypeName(bf) = "Boolean" Then
                    Exit Sub
                ElseIf bf = 0 Then
                    Set myPopup = CommandBars("Cell").Controls.Add(Type:=msoControlPopup)
                ElseIf bf >= 1 And bf <= CommandBars("Cell").Controls.Count Then
                    Set myPopup = CommandBars("Cell").Controls.Add(Type:=msoControlPopup, Before:=bf) 'Before:=で配置位置を指定する。省略で末尾に配置
                Else
                    MsgBox "0~" & CommandBars("Cell").Controls.Count & "の数値で入力して下さい"
                    GoTo bfrr
                End If
            myPopup.Caption = ct '追加するメニュー名を入力
bgrr:
            bg = Application.InputBox(Prompt:="サブメニューを含むメニューの上側に区切り線を入れますか?" & vbCrLf & _
            "1:入れる" & vbCrLf & "2:入れない", Type:=1)
                If TypeName(bg) = "Boolean" Then
                    Exit Sub
                ElseIf bg = 1 Then
                    myPopup.BeginGroup = True  'Trueで上側に区切り線が表示される。Falseで区切り線なし
                ElseIf bg = 2 Then
                    myPopup.BeginGroup = False
                Else
                    MsgBox "1または2を入力して下さい!"
                    GoTo bgrr
                End If

        Case 3
ctsw:
            On Error GoTo ErrorHandler
            cts = Application.InputBox(Prompt:="サブメニュー名を入力して下さい", Type:=2)
                If TypeName(cts) = "Boolean" Then
                    Exit Sub
                ElseIf cts = "" Then
                    GoTo ctsw
                End If
ctw:
            ct = Application.InputBox(Prompt:="サブメニューの上位階層のメニュー名を入力して下さい", Type:=2)
                If TypeName(ct) = "Boolean" Then
                    Exit Sub
                ElseIf ct = "" Then
                    GoTo ctw
                End If
oaw:
            oa = Application.InputBox(Prompt:="サブメニューに登録するマクロ名を入力して下さい", Type:=2)
                If TypeName(oa) = "Boolean" Then
                    Exit Sub
                ElseIf oa = "" Then
                    GoTo oaw
                End If
bfw:
            bf = Application.InputBox(Prompt:="サブメニューを上から何番目に配置しますか?(0で末尾)", Type:=1)
                If TypeName(bf) = "Boolean" Then
                    Exit Sub
                ElseIf bf = 0 Then
                    Set myButton = CommandBars("Cell").Controls(ct).Controls.Add
                ElseIf bf >= 1 And bf <= CommandBars("Cell").Controls(ct).Controls.Count Then
                    Set myButton = CommandBars("Cell").Controls(ct).Controls.Add(Before:=bf) 'Before:=で配置位置を指定する。省略で末尾に配置
                Else
                    MsgBox "0~" & CommandBars("Cell").Controls(ct).Controls.Count & "の数値で入力して下さい"
                    GoTo bfw
                End If
            myButton.Caption = cts '追加するサブメニュー名を入力
            myButton.OnAction = oa    '実行するマクロ名を入力
bgw:
            bg = Application.InputBox(Prompt:="サブメニューの上側に区切り線を入れますか?" & vbCrLf & _
            "1:入れる" & vbCrLf & "2:入れない", Type:=1)
                If TypeName(bg) = "Boolean" Then
                    Exit Sub
                ElseIf bg = 1 Then
                    myButton.BeginGroup = True  'Trueで上側に区切り線が表示される。Falseで区切り線なし
                ElseIf bg = 2 Then
                    myButton.BeginGroup = False
                Else
                    MsgBox "1または2を入力して下さい!"
                    GoTo bgw
                End If
                       
        Case 4
ctx:
            On Error GoTo ErrorHandler
            ct = Application.InputBox(Prompt:="削除するメニュー名を入力して下さい", Type:=2)
                If TypeName(ct) = "Boolean" Then
                    Exit Sub
                ElseIf ct = "" Then
                    GoTo ctx
                End If
            CommandBars("Cell").Controls(ct).Delete   '削除するメニュー名を入力
           
        Case 5
ctsx:
            On Error GoTo ErrorHandler
            cts = Application.InputBox(Prompt:="削除するサブメニュー名を入力して下さい", Type:=2)
                If TypeName(cts) = "Boolean" Then
                    Exit Sub
                ElseIf cts = "" Then
                    GoTo ctsx
                End If
ctsz:
            ct = Application.InputBox(Prompt:="サブメニューの上位階層のメニュー名を入力して下さい", Type:=2)
                If TypeName(ct) = "Boolean" Then
                    Exit Sub
                ElseIf ct = "" Then
                    GoTo ctsz
                End If
            CommandBars("Cell").Controls(ct).Controls(cts).Delete   '削除するサブメニュー名を入力
           
        Case 6
            CommandBars("Cell").Reset
       
        End Select
       
    Exit Sub
ErrorHandler:
    Select Case Err.Number
        Case 5
            MsgBox "入力された名称が間違っているか、存在しません"
    End Select
End Sub
***************************************

 ※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。

 

右クリックした際の第一階層メニューには隠しメニューなどがあるので、追加するメニューを配置する正確な順番を知りたい場合は下記の記事のマクロを使用下さい。

 

kouten0430.hatenablog.com