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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
| Option Explicit
Public Function derlig_reelle(plage As Range) As Long
'cas d'absence de données dans la plage à traiter :
If WorksheetFunction.CountA(plage) = 0 Then derlig_reelle = 1: Exit Function
'dans tous les autres cas :
derlig_reelle = plage.Find("*", , , , , xlPrevious).Row
End Function
Public Function Filtre_Tableau(ByVal Tableau As Variant, _
Colonne As Long, _
Key1 As Variant, _
Optional test As String = "=") As Variant
'Filtre un tableau à 2 dimensions en fonction du contenu d'une colonne
'
'!!!!!!!!! utilise les fonctions : Nb_Dimensions & Transposition
'
'PARAMETRES
'Tableau = Array de variant à 2 dimensions
'Colonne = numéro de la colonne contenant les données à filtrer
'Key1 = comparateur, donnée à laquelle comparer les données de la colonne Colonne
'Test = opérateur parmi : "=", "<", "<=", ">", ">=", "Like", "<>" (à passer en String donc avec guillemets)
Dim Tbl() As Variant, i As Long, j As Long, Cpt As Long, TestColonne As Variant
On Error GoTo Erreur_Colonne
TestColonne = Tableau(LBound(Tableau, 1), Colonne)
On Error GoTo 0
Select Case Nb_Dimensions(Tableau)
Case 0
MsgBox "Le tableau passé en paramètre est vide."
Case 1
MsgBox "Le tableau passé en paramètre ne comporte qu'une colonne. La fonction n'est pas adaptée à ce cas."
Case 2
Select Case test
Case "="
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) = Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(1 To UBound(Tableau, 2), 1 To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case "<"
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) < Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(1 To UBound(Tableau, 2), 1 To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case ">"
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) > Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(1 To UBound(Tableau, 2), 1 To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case "<="
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) <= Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(1 To UBound(Tableau, 2), 1 To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case ">="
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) >= Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(1 To UBound(Tableau, 2), 1 To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case "<>"
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) <> Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(1 To UBound(Tableau, 2), 1 To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case "Like"
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) Like Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(1 To UBound(Tableau, 2), 1 To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case Else
MsgBox "Le paramètre facultatif Test est erroné."
Exit Function
End Select
On Error GoTo resultat_Vide
TestColonne = Tbl(UBound(Tbl, 1), UBound(Tbl, 2))
On Error GoTo 0
Filtre_Tableau = Transposition(Tbl)
Erase Tbl
Case Else
MsgBox "Le tableau comporte plus de deux dimensions. La fonction n'est pas adaptée à ce cas."
End Select
Exit Function
Erreur_Colonne:
MsgBox "Le paramètre Colonne est erroné."
Exit Function
resultat_Vide:
MsgBox "Le filtre renvoie un tableau vide de données."
End Function
Public Function Nb_Dimensions(Tableau As Variant) As Integer
'Calcule le nombre de dimensions d'un tableau
'PARAMETRE
'Tableau = Array de Variant à 0, 1 ou plusieurs dimensions
Dim D As Integer, t As Integer
On Error GoTo Fin
Do: D = D + 1: t = UBound(Tableau, D): Loop
Fin:
Nb_Dimensions = D - 1
End Function
Public Function Range_To_Tb(plage As Range) As Variant()
'Converti sans faille un range en tableau
'
' Le tableau ainsi obtenu est toujours en option base 1
' ET à 2 dimensions
'PARAMETRE
'plage = Range (plage de cellule(s))
If plage.Cells.Count < 2 Then
Dim tablo(1 To 1, 1 To 1)
tablo(1, 1) = plage.Value
Range_To_Tb = tablo
Erase tablo
Else
Range_To_Tb = plage.Value
End If
End Function
Public Function Transposition(ByRef Tableau As Variant) As Variant
'Transpose, en lignes, un tableau à 2 dimensions de plus de 65536 Colonnes
'
'!!!!!!!!! utilise la fonction : Nb_Dimensions
'
'PARAMETRE
'Tableau = Array de Variant à 2 dimensions
Select Case Nb_Dimensions(Tableau)
Case 0
MsgBox "Le tableau passé en paramètre est vide."
Case 1
MsgBox "Le tableau passé en paramètre ne comporte qu'une colonne. La fonction n'est pas adaptée à ce cas."
Case 2
Dim Tabl, i As Long, j As Long
ReDim Tabl(1 To UBound(Tableau, 2), 1 To UBound(Tableau, 1))
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tabl(j, i) = Tableau(i, j)
Next j
Next i
Transposition = Tabl
Erase Tabl
Case Else
MsgBox "Le tableau comporte plus de deux dimensions. La fonction n'est pas adaptée à ce cas."
End Select
End Function |
Alternative à Sub ComboBox1_Change()
et
Répondre avec citation
sans le comprendre et sans savoir comment l'adapter, ça ne me ferai pas avancer 
or je suis sur ce forum pour cela avancer 
.
Partager