Cette procédure permet en outre d'avoir la liste triée dans le menu
'***********************************
'partie à placer dans Thisworkbook
'***********************************
Option Explicit
'Macro de Ti alias Thierry Pourtier / juin 2002
'cela ne nous rajeunit pas !!!
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim Ctrl As CommandBarControl
Dim Cel As Range, Plage As Range
Dim NbItem As Long, Boucle As Long
Dim DejaPris As Boolean
For Each Ctrl In Application.CommandBars("cell").Controls
If Ctrl.Tag = "brccm" Then Ctrl.Delete
Next Ctrl
With ActiveCell
If .Row = 1 Then Exit Sub
ReDim ListItem(1 To .Row)
Set Plage = Range(Cells(1, .Column), .Offset(-1, 0))
End With
For Each Cel In Plage
'inutile de boucler au delà de NbItem, le reste sera vide !
For Boucle = 1 To NbItem
If Cel.Value = ListItem(Boucle) Then
DejaPris = True
Exit For
End If
Next Boucle
If Not DejaPris And Cel.Value <> "" Then
NbItem = NbItem + 1
ListItem(NbItem) = Cel.Value
End If
DejaPris = False
Next Cel
'tri du tableau et affectation au menu
If NbItem > 0 Then
TrieTableau ListItem, 1, NbItem
'il faut boucler à l'envers pour retrouver le bon ordre
For Boucle = NbItem To 1 Step -1
With Application.CommandBars("cell").Controls _
.Add(Type:=msoControlButton, before:=6, temporary:=True)
.Caption = CStr(ListItem(Boucle))
.OnAction = "EcrisValeur(" & Boucle & ")"
.Tag = "brccm"
End With
Next Boucle
End If
End Sub
'******************************
'partie à placer dans un module
'******************************
Option Explicit
'Macro de Ti alias Thierry Pourtier / juin 2002 /
'cela ne nous rajeunit pas !!!
Public ListItem() As Variant
Sub TrieTableau(PTableau, Deb As Long, Fin As Long)
' cette procédure travaille récursivement
Dim IndiceInf As Long, IndiceSup As Long
Dim Temp, Pivot
IndiceInf = Deb
IndiceSup = Fin
Pivot = UCase(PTableau((Deb + Fin) 2))
Do
While UCase(PTableau(IndiceInf)) < Pivot
IndiceInf = IndiceInf + 1
Wend
While Pivot < UCase(PTableau(IndiceSup))
IndiceSup = IndiceSup - 1
Wend
If IndiceInf <= IndiceSup Then
Temp = PTableau(IndiceInf)
PTableau(IndiceInf) = PTableau(IndiceSup)
PTableau(IndiceSup) = Temp
IndiceInf = IndiceInf + 1
IndiceSup = IndiceSup - 1
End If
Loop Until IndiceInf > IndiceSup
If Deb < IndiceSup Then TrieTableau PTableau, Deb, IndiceSup
If IndiceInf < Fin Then TrieTableau PTableau, IndiceInf, Fin
End Sub
Sub EcrisValeur(PIndex)
ActiveCell.Value = ListItem(PIndex)
End Sub