Listes sans doublons triée

La liste est dans la colonne A et contient des doublons. Pour obtenir une liste sans doublons dans le combobox, on vérifie si l'élément existe déjà dans le combobox avant de l'ajouter (3,5sec pour 5.000 éléments).Attention! active l'événement Change().

Private Sub UserForm_Initialize()
  For i = 1 To Sheets(1).[A65000].End(xlUp).Row
      Me.ComboBox1 = Sheets(1).Cells(i, "A")        ' on se positionne dans le combobox
      If Me.ComboBox1.ListIndex = -1 Then           ' Existe t-il?
         Me.ComboBox1.AddItem Sheets(1).Cells(i, "A")
      End If
   Next i
End Sub

Liste sans doublons avec Dictionnary

On veut une liste déroulante sans doublons (0,15 sec pour 5.000 éléments).

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set mondico = CreateObject("Scripting.Dictionary")
  a = f.Range("A2:A" & f.[A65000].End(xlUp).Row) ' tableau a(n,1) pour rapidité
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then mondico(a(i, 1)) = ""
  Next i
  Me.ComboBox1.List = MonDico.keys
End Sub

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set mondico = CreateObject("Scripting.Dictionary")
  a = f.Range("A2:A" & f.[A65000].End(xlUp).Row)   ' tableau a(n,1) pour rapidité
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then mondico(a(i, 1)) = ""
  Next i
  '--avec tri
  temp = mondico.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
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

Sur MAC, Dictionary n'existe pas. Pour obtenir une liste sans doublons triée rapide:

FormLSDMAC

Option Compare Text
Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("base")
  Dim a()
  a = Application.Transpose(f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value)
  Me.ComboBox1.List = SansDoublonsTriéMAC(a())
End Sub

Function SansDoublonsTriéMAC(a())
  Call Tri(a, LBound(a), UBound(a))
  Dim b(): ReDim b(1 To UBound(a))
  i = 1: j = 0
  Do While i <= UBound(a)
    j = j + 1: b(j) = a(i)
    Do While a(i) = b(j)
       i = i + 1: If i > UBound(a) Then Exit Do
    Loop
  Loop
  ReDim Preserve b(1 To j)
  SansDoublonsTriéMAC = Application.Transpose(b)
End Function

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

Fonction SansDoublonsTrié()

Private Sub UserForm_Initialize()
Me.ComboBox1.List = SansDoublonsTrié(Application.Transpose(Range("A2:A" & [A65000].End(xlUp).Row)))
End Sub

Function SansDoublonsTrié(a)
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In a
    d(c) = ""
  Next c
  b = d.keys
  Call Tri(b, LBound(b), UBound(b))
  SansDoublonsTrié = Application.Transpose(b)
End Function

Listes sans doublons avec 2 colonnes (Nom+prénom)

Dim f, a()
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  a = f.Range("A2:D" & f.[B65000].End(xlUp).Row).Value
  Set d = CreateObject("Scripting.Dictionary")
  Dim Tbl(1 To 2)
  For i = 1 To UBound(a)
   Tbl(1) = a(i, 1)
   Tbl(2) = a(i, 2)
   d(a(i, 1) & a(i, 2)) = Tbl
  Next i
  Dim b(): ReDim b(1 To 2, 1 To d.Count)
  i = 0
  For Each c In d.keys
    i = i + 1
    b(1, i) = d(c)(1)
    b(2, i) = d(c)(2)
  Next c
  Dim temp()
  temp = Application.Transpose(b)
  Call Tri(temp(), 1, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
End Sub

Pour que le tri soit indépendant des majuscules/minuscules

Liste sans doublons triée (Filtre élaboré)

ListeTrieeFiltre.xls

La liste en colonne C est modifiée à chaque modif en colonne A

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
    Application.EnableEvents = False
    [A1:A1000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:= _
       Sheets("ListeSansDoublonsTriéFiltre").[c1], Unique:=True
    [C2:c100].Sort Key1:=Range("c2")
    Application.EnableEvents = True
End If
End Sub-

La propriété RowSource du comboBox contient le nom de champ dynamique(Maliste2)

ou sans nom de champ dynamique

Me.ComboBox1.RowSource = "C2:C" & [C65000].End(xlUp).Row

Liste sans doublons triée (sans liste intermédiaire)

On tri d’abord la BD

Private Sub UserForm_Initialize()
   Dim temp()
   ReDim temp(100)
   Sheets("ListeSansDoublonsTrié3").[a2:A1000].Sort Key1:=[a2]
   i = 0
   For Each c In Range([a2], [a65000].End(xlUp))
     If IsError(Application.Match(c, temp, 0)) Then
       temp(i) = c
       i = i + 1
     End If
   Next c
   ReDim Preserve temp(i - 1)
   Me.ComboBox1.List = temp
End Sub

Liste sans doublons triée avec Collection - tri dans le tableur -

Private Sub UserForm_Initialize()
  Dim temp As New Collection
  [a2:A1000].Sort Key1:=[a2]
  On Error Resume Next
  For Each c In Range([a2], [A65000].End(xlUp))
    temp.Add Item:=c, key:=CStr(c)
  Next c
  On Error GoTo 0
  For Each i In temp
     Me.ComboBox1.AddItem i
  Next i
End Sub

Liste sans doublons triée avec Collection - tri dans un tableau -

(0,9 s pour 10.000 éléments)

Private Sub UserForm_Initialize()
   Dim TempCol As New Collection
   On Error Resume Next
   For Each c In Range([A2], [A65000].End(xlUp))
     TempCol.Add Item:=c, key:=CStr(c)
   Next c
   On Error GoTo 0
   '-- transfert dans un tableau
   Dim TempTab()
   ReDim TempTab(1 To TempCol.Count)
   For i = 1 To TempCol.Count
     TempTab(i) = TempCol(i)
   Next
   Call Tri(TempTab, 1, UBound(TempTab, 1))
   Me.ComboBox1.List = TempTab
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

Liste sans doublons triée avec ADO

Nom de champ MaListe= $A$1:$A$18

Private Sub UserForm_Initialize()
' dans Outils/Références cocher
' Microsoft ActivexDataObject 2.8 Library
ChDir ActiveWorkbook.Path
Dim rs As ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=FormComboboxSansDoublons.XLS"
Set rs = cnn.Execute("SELECT service FROM MaListe GROUP BY Service")
Do While Not rs.EOF
Me.Choix.AddItem rs("Service")
rs.MoveNext
Loop
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub