XL 2013 afficher les onglets du classeur dans menu clic droit

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim s As Object
Cancel = True
For Each s In Me.Sheets
    UserForm1.ListBox1.AddItem s.Name
Next
UserForm1.Show 0 'non modal'
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    W_Brc Target, Cancel
End Sub

Sub W_Brc(ByVal Target As Range, Cancel As Boolean) ' Worksheet_BeforeRightClick
Dim Sh      As Worksheet
Dim Control As Object
Dim Rbar    As CommandBar
Const Cb = "RightClick"
    Cancel = True
    On Error Resume Next: CommandBars(Cb).Delete: On Error GoTo 0
    Set Rbar = CommandBars.Add(Cb, msoBarPopup, , True)
    With Rbar
        With .Controls.Add(msoControlPopup, , , .Controls.Count + 1, True)
            .Caption = "Activer feuille"
            For Each Sh In ThisWorkbook.Worksheets
                Select Case True
                Case Sh.Name = ActiveSheet.Name
                Case Sh.Type <> xlWorksheet
                Case Else
                    With .Controls.Add(msoControlButton, , , , True)
                        .Caption = Sh.Name
                        .FaceId = 1154
                        .OnAction = "Show_Tab"
                    End With
                End Select
            Next
        End With
         For Each Sh In ThisWorkbook.Worksheets
            Select Case True
            Case Sh.Name = ActiveSheet.Name
            Case Sh.Type <> xlWorksheet
            Case Else
                With .Controls.Add(msoControlButton, , , , True)
                    .Caption = Sh.Name
                    .FaceId = 634
                    .OnAction = "Show_Tab"
                End With
            End Select
        Next
        Copy_Controls Rbar, IIf(ActiveCell.ListObject Is Nothing, "Cell", "List Range Popup")
        .ShowPopup
        .Delete
    End With
                
End Sub
Sub Copy_Controls(To_Bar As CommandBar, From_Bar As String, Optional BlankLine As Boolean = False)
Dim CBar    As CommandBarControl
On Error Resume Next
    With To_Bar
        ' Ligne de séparation
        If BlankLine Then .Controls.Add(msoControlButton, , , .Controls.Count + 1, True).Caption = ""
        ' Controls habituels du click droit
        With .Controls.Add(msoControlPopup, , , .Controls.Count + 1, True)
            ' .BeginGroup = True
             .Caption = "Autres Choix"
            For Each CBar In CommandBars(From_Bar).Controls
                .Controls.Add CBar.Type, CBar.ID, , , True
            Next
         End With
    End With

End Sub
Sub Show_Tab()
Dim Target As String
    With CommandBars.ActionControl
        Select Case .Type
        Case msoControlButton: Target = .Caption
        Case msoControlDropdown: Target = .Text
        Case Else: Exit Sub
        End Select
        With Worksheets(Target)
            .Visible = True
            .Activate
        End With
    End With
End Sub

Private Sub Workbook_Activate()
Application.CommandBars("Cell").Reset
Dim Compteur%, Compteur2%
For Compteur = ThisWorkbook.Sheets.Count To 1 Step -1
    If ThisWorkbook.Sheets(Compteur).Visible = True Then
        Compteur2 = Compteur2 + 1
        With Application.CommandBars("Cell")
            With .Controls.Add(Type:=msoControlButton, Before:=1)
                .OnAction = ThisWorkbook.Name & "!'Thisworkbook.Select_Dest " & Chr(34) & ThisWorkbook.Sheets(Compteur).Name & Chr(34) & "'"
                .FaceId = 350
                .Caption = ThisWorkbook.Sheets(Compteur).Name
            End With
        End With
    End If
Next Compteur
Application.CommandBars("Cell").Controls(Compteur2 + 1).BeginGroup = True
End Sub
Private Sub Workbook_Deactivate()
Application.CommandBars("Cell").Reset
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.CommandBars("Cell").Reset
End Sub
Private Sub Select_Dest(Nom_Feuille$)
    Application.Goto Reference:=ThisWorkbook.Sheets(Nom_Feuille).Range(ActiveCell.Address)
    ActiveCell.Select
End Sub

Private Sub Select_Dest(Nom_Feuille$)
    ThisWorkbook.Sheets(Nom_Feuille).Select
End Sub

Sub W_Brc(ByVal Target As Range, Cancel As Boolean) ' Worksheet_BeforeRightClick
Dim Sh      As Worksheet
Dim Control As Object
Dim Rbar    As CommandBar
Const Cb = "RightClick"
    Cancel = True
    On Error Resume Next: CommandBars(Cb).Delete: On Error GoTo 0
    Set Rbar = CommandBars.Add(Cb, msoBarPopup, , True)
    With Rbar
        With .Controls.Add(msoControlPopup, , , .Controls.Count + 1, True)
            .Caption = "Activer feuille"
            For Each Sh In ThisWorkbook.Worksheets
                Select Case True
                Case Sh.Name = ActiveSheet.Name
                Case Sh.Type <> xlWorksheet
                Case Else
                    With .Controls.Add(msoControlButton, , , , True)
                        .Caption = Sh.Name
                        .FaceId = 1154
                        .OnAction = "Show_Tab"
                    End With
                End Select
            Next
        End With
        Copy_Controls Rbar, IIf(ActiveCell.ListObject Is Nothing, "Cell", "List Range Popup"), True
        .ShowPopup
        .Delete
    End With
                
End Sub
Sub Copy_Controls(To_Bar As CommandBar, From_Bar As String, Optional BlankLine As Boolean = False)
Dim CBar    As CommandBarControl
On Error Resume Next
    With To_Bar
        ' Ligne de séparation
        If BlankLine Then .Controls.Add(msoControlButton, , , .Controls.Count + 1, True).Caption = ""
        ' Controls habituels du click droit
'        With .Controls.Add(msoControlPopup, , , .Controls.Count + 1, True)
'            ' .BeginGroup = True
'             .Caption = "Autres Choix"
            For Each CBar In CommandBars(From_Bar).Controls
                .Controls.Add CBar.Type, CBar.ID, , , True
            Next
'         End With
    End With

End Sub
Sub Show_Tab()
Dim Target As String
    With CommandBars.ActionControl
        Select Case .Type
        Case msoControlButton: Target = .Caption
        Case msoControlDropdown: Target = .Text
        Case Else: Exit Sub
        End Select
        With Worksheets(Target)
            .Visible = True
            .Activate
        End With
    End With
End Sub

Private Sub Workbook_Activate()
DoEvents
Application.CommandBars("Cell").Reset
Dim Compteur%
With Application.CommandBars("Cell")
    With .Controls.Add(msoControlPopup, , , 1, True)
        .Caption = "Aller à l'onglet ..."
        For Compteur = ThisWorkbook.Sheets.Count To 1 Step -1
            If ThisWorkbook.Sheets(Compteur).Visible = True Then
                With .Controls.Add(Type:=msoControlButton, Before:=1)
                    .OnAction = ThisWorkbook.Name & "!'Thisworkbook.Select_Feuille " & Chr(34) & ThisWorkbook.Sheets(Compteur).Name & Chr(34) & "'"
                    .FaceId = 350
                    .Caption = ThisWorkbook.Sheets(Compteur).Name
                End With
            End If
        Next Compteur
    End With
    .Controls(2).BeginGroup = True
End With
End Sub
Private Sub Workbook_Deactivate()
Application.CommandBars("Cell").Reset
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.CommandBars("Cell").Reset
End Sub
Private Sub Select_Feuille(Nom_Feuille$)
    If Feuille_Existe(Nom_Feuille) Then
        Sheets(Nom_Feuille).Select
    Else
        MsgBox "La feuille " & Nom_Feuille & " n'existe plus, menu contextuel réinitialisé.", vbOKOnly + vbInformation
        Workbook_Activate
    End If
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
    Workbook_Activate
End Sub
Private Sub Workbook_SheetBeforeDelete(ByVal Sh As Object)
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!Thisworkbook.Workbook_Activate"
End Sub
Function Feuille_Existe(NomFeuille$) As Boolean
    On Error Resume Next
    Set Test_objet = ActiveWorkbook.Sheets(NomFeuille)
    Feuille_Existe = Not Test_objet Is Nothing
End Function

Private Sub Workbook_BeforeClose(Cancel As Boolean)
CommandBars("Cell").Reset
End Sub
Private Sub Workbook_Open()
UPDATE_BAR
End Sub
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
UPDATE_BAR
End Sub

Sub UPDATE_BAR()
    Dim bar, sh As Worksheet, pop
    Set bar = CommandBars("Cell"): bar.Reset
    Set pop = bar.Controls.Add(msoControlPopup, Before:=1)    'sub menu global
    pop.Caption = "mes feuilles"    'a adapter
    For Each sh In Worksheets
        With pop.Controls.Add(msoControlButton):
            .Caption = sh.Name: .OnAction = "sheetsshow"
        End With
    Next
End Sub

Sub sheetsshow()
Sheets(Application.CommandBars.ActionControl.Caption).Activate
End Sub