[Résolu] Liste deroulante classée par ordre alphabétique et sans doublons

Private Sub supprimeDoublons()
    MaCellule = "A1"
    Range(MaCellule).Select
    ActiveCell.CurrentRegion.Sort Key1:=Range(MaCellule), Order1:=xlAscending, Header:=xlYes
    donnee1 = ActiveCell
    While ActiveCell <> ""
        ActiveCell.Offset(1, 0).Select
        If ActiveCell = donnee1 Then
            ActiveCell.Offset(-1, 0).Select
            ActiveCell.EntireRow.Delete
            donnee1 = ActiveCell
        Else
            donnee1 = ActiveCell
        End If
    Wend
End Sub

Private Sub Worksheet_Activate()
Me.Range("S:S").Clear
Set liste = CreateObject("scripting.dictionary")
With Sheets("Societe")
For Each c In .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row)
    liste(c.Value) = c.Value
Next c
End With
Me.Range("S1:S" & liste.Count) = Application.Transpose(liste.keys)
Me.Range("S1:S" & liste.Count).Sort key1:=Range("S1"), order1:=xlAscending, Header:=xlNo
End Sub

Sub listeprestataires_courte()
'Misange 2012
Dim MesPrestataires
Dim UnTri As String

 'première solution, en utilisant directement le résultat du dictionnaire trié
 'comme source pour la validation, sans passer par la feuille
 'valable seulement si il ya peu de prestataires
 'limite : le nom défini ne peut pas comprendre plus de 250 caractères, virgules incluses...
 'pour tester cette solution, une courte liste de prestataires a été créée dans la page test
 
Set MesPrestataires = CreateObject("Scripting.Dictionary")
For Each c In Range("test[test]")
If Not MesPrestataires.Exists(c.Value) Then MesPrestataires.Add c.Value, c.Value
Next c
Temp = MesPrestataires.items
Call Tri(Temp, LBound(Temp), UBound(Temp))
 
For Each i In Temp
    UnTri = UnTri & i
    If a < UBound(Temp) Then UnTri = UnTri & ","
    a = a + 1
Next
 Set dv = Range("choix[prestataires]").Validation
   dv.Delete
   dv.Add xlValidateList, xlValidAlertStop, xlBetween, UnTri
 
 End Sub


Sub listeprestataires_longue()
'Misange 2012
Dim MesPrestataires
Dim UnTri As String

'seconde solution, si le nombre d'items dans le dictionnaire est assez grand
'la liste des éléments uniques et triés est mise dans la colonne Q qui est masquée
With Sheets("choix_prestataires").Columns("Q:Q")
    .EntireColumn.Hidden = True
    .Clear
End With


Set MesPrestataires = CreateObject("Scripting.Dictionary")
For Each c In Range("société[societe]")
If Not MesPrestataires.Exists(c.Value) Then MesPrestataires.Add c.Value, c.Value
Next c
Temp = MesPrestataires.items
Call Tri(Temp, LBound(Temp), UBound(Temp))

With Sheets("choix_prestataires")
.Range("Q1:Q" & MesPrestataires.Count) = Application.WorksheetFunction.Transpose(Temp)
End With

Set dv = Range("choix[prestataires]").Validation
dv.Delete
dv.Add xlValidateList, xlValidAlertStop, xlBetween, "=$Q$1:$Q$" & MesPrestataires.Count

 End Sub



Sub Tri(a, gauc, droi)   ' Quick sort
 ref = a((gauc + droi) \ 2)
 g = gauc: d = droi
 Do
  Do While a(g) < ref: g = g + 1: Loop
  Do While ref < a(d): d = d - 1: Loop
  If g <= d Then
  Temp = a(g): a(g) = a(d): a(d) = Temp
  g = g + 1: d = d - 1
  End If
 Loop While g <= d
 If g < droi Then Call Tri(a, g, droi)
 If gauc < d Then Call Tri(a, gauc, d)
 End Sub