|
Accueil
Liste sans doublons avec Dictionary
Liste sans doublons avec Dictionary trié
Liste triée avec accent
Majuscule / Minuscule
Filtre élaboré
Liste sans doublons avec ADO
Liste sans doublons
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)..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).
Liste Sans Doublons
Combobox Numérique Sans doublons Trié
Private Sub UserForm_Initialize()
Set f = Sheets("BD")
Set mondico = CreateObject("Scripting.Dictionary")
a = f.Range("A2:A" & f..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
Version liste triée
Private Sub UserForm_Initialize()
Set f = Sheets("BD")
Set mondico = CreateObject("Scripting.Dictionary")
a = f.Range("A2:A" & f..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
Liste sans doublons triée avec accent
Zoo est classé après Zoé
ListeSansDoublonsAccent.xls
ListeSansDoublonsAccentNbItems.xls
Private Sub UserForm_Initialize()
Set f = Sheets("BD")
Set MonDico = CreateObject("Scripting.Dictionary")
For Each c In Range(f., f..End(xlUp))
If c.Value <> "" Then MonDico.Item(c.Value) = c.Value
Next c
temp = MonDico.items
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 sansAccent(a(g)) < sansAccent(ref): g = g + 1: Loop
Do While sansAccent(ref) < sansAccent(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
Function sansAccent(chaine)
codeA = "ÉÈÊËÔéèêëàçùôûïî"
codeB = "EEEEOeeeeacuouii"
temp = chaine
For i = 1 To Len(temp)
p = InStr(codeA, Mid(temp, i, 1))
If p > 0 Then Mid(temp, i, 1) = Mid(codeB, p, 1)
Next
sansAccent = temp
End Function
Pour que le tri soit indépendant des majuscules/minuscules
Marin est classé avec MARIN.
OPTION COMPARE TEXT dans un module
ou
Sub Tri(a, gauc, droi) ' Quick sort
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While UCase(SansAccent(a(g))) < UCase(SansAccent(ref)): g = g + 1: Loop
Do While UCase(SansAccent(ref)) < UCase(SansAccent(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 (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")., 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" & .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:=
i = 0
For Each c In Range(, .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:=
On Error Resume Next
For Each c In Range(, .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(, .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
|