Remplir des cellules à l'aide d'un [menu contextuel]

Sub AddToCellMenu()
Dim ContextMenu As CommandBar
Dim MySubMenu As CommandBarControl
Call DeleteFromCellMenu
Set ContextMenu = Application.CommandBars("Cell")
Set MySubMenu = ContextMenu.Controls.Add(Type:=msoControlPopup, before:=3)
    With MySubMenu
        .Caption = "Test Menu-contextuel"
        .Tag = "My_Cell_Control_Tag"

        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "Test1"
            .FaceId = 160
            .Caption = "Sous-menu 1"
        End With
        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "Test2"
            .FaceId = 127
            .Caption = "Sous-menu 2"
        End With
        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "Test3"
            .FaceId = 213
            .Caption = "Sous-menu 3"
        End With

    End With
ContextMenu.Controls(4).BeginGroup = True
End Sub
Sub DeleteFromCellMenu()
    Dim ContextMenu As CommandBar, ctrl As CommandBarControl
    Set ContextMenu = Application.CommandBars("Cell")
    For Each ctrl In ContextMenu.Controls
        If ctrl.Tag = "My_Cell_Control_Tag" Then
            ctrl.Delete
        End If
    Next ctrl
    On Error Resume Next
    ContextMenu.FindControl(ID:=3).Delete
    On Error GoTo 0
End Sub
Sub Test1()
MsgBox Time, vbCritical, "Test1"
End Sub
Sub Test2()
MsgBox Date, vbExclamation, "Test2"
End Sub
Sub Test3()
MsgBox Application.UserName, vbMsgBoxRtlReading, "Test3"
End Sub