1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
Private Sub Worksheet_Change(ByVal Target As Range)
Dim CmbListe As OLEObject
Dim Combo As MSForms.ComboBox
Dim Tbl()
Dim Plage As Range
Dim I As Long
'si une valeur change dans la colonne A
If Not Intersect(Target, [A:A]) Is Nothing Then
'défini la plage des valeurs à dédoublonner et trier
With ActiveSheet
Set Plage = .Range(.[A1], .Range("A" & Rows.Count).End(xlUp))
End With
'rempli le tableau avec la plage
For I = 1 To Plage.Count
ReDim Preserve Tbl(1 To I)
Tbl(I) = Plage(I)
Next I
'supprime les doublons
Tbl = SupprimerDoublons(Tbl)
'tri le tableau (voir la proc pour sens du tri)
Tri Tbl
'supprime le combo si il existe
On Error Resume Next
ActiveSheet.OLEObjects("CmbListe").Delete
On Error GoTo 0
'le rajoute en position et dimensions de la cellule B1
With Range("B1")
Set CmbListe = Me.OLEObjects.Add(ClassType:="Forms.ComboBox.1", _
Link:=False, DisplayAsIcon:=False, Left:=.Left, Top:=.Top, _
Width:=.Width, Height:=.Height)
End With
'un combobox OLEObject n'a pas de méthode AddItem
'on affecte alors sa propriété Object à un objet "MSForms.ComboBox"
'qui lui à bien une méthode AddItem (ComboBox mis sur UserForm)
With CmbListe
.Name = "CmbListe"
Set Combo = .Object
End With
'le remplissage de sa liste est maintenant possible
'avec les valeurs unique et triées
For I = 1 To UBound(Tbl)
Combo.AddItem Tbl(I)
Next I
End If
End Sub
Function SupprimerDoublons(Tbl()) As Variant()
Dim Dico As Object
Dim Cle
Dim T()
Dim I As Long
'crée l'objet
Set Dico = CreateObject("Scripting.Dictionary")
'inscrit les valeurs dans le dictionnaire
'en affectant aussi cette valeur à la clé
'une clé devant être unique, si on ne contrôle pas
'son existance dans la collection, un erreur est générée
For I = 1 To UBound(Tbl)
If Dico.Exists(Tbl(I)) = False Then
Dico.Add Tbl(I), Tbl(I)
End If
Next I
I = 0
'tranfert des valeurs uniques dans un tableau
For Each Cle In Dico.keys
I = I + 1
ReDim Preserve T(1 To I)
T(I) = Cle
Next
'passage de ce tableau à la fonction
SupprimerDoublons = T
'libère la mémoire
Set Dico = Nothing
End Function
Sub Tri(Tbl())
Dim Tempo
Dim I As Integer
Dim J As Integer
Do While I < UBound(Tbl) - 1
I = I + 1
Do While J < UBound(Tbl)
J = J + 1
'tri décroissant "<"
'tri croissant ">"
If Tbl(I) > Tbl(J) Then
Tempo = Tbl(J)
Tbl(J) = Tbl(I)
Tbl(I) = Tempo
End If
Loop
J = I
Loop
End Sub
Private Sub CmbListe_Click()
'ici on récupère le choix fait dans la liste
'à adapter aux bessoins...!
MsgBox CmbListe.Text
End Sub |
Liste déroulante avec filtre et tri sans doublon
Répondre avec citation
.
Partager