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
| '### Constantes et variables de portée niveau module ###
'/// Constantes à adapter ///
Const FIRST_CELL_CAPABILITE As String = "C10" 'La 1ère cellule du tableau Excel (à adapter)
Const LISTBOX_METIERS As String = "listbox1" 'Nom exact de la ListBox des Métiers (à adapter)
Const DROPDOWN_RISQUES As String = "ListeRisque" 'Nom exact de la DropDown des Risques (à adapter)
Const DROPDOWN_RANGS As String = "ListeRang" 'Nom exact de la DropDown des Rangs (à adapter)
'////////////////////////////
Dim LB As Excel.ListBox 'Contrôle de formulaire (ce n'est pas un ActiveX)
Dim DD As Excel.DropDown 'Contrôle de formulaire (ce n'est pas un ActiveX)
'#######################################################
Sub ListBox2Filtre()
Dim Coll As New Collection
Dim R As Range
Dim LesMetiers$
Dim Tbl As Variant
Dim var As Variant
Dim k&
Dim i&
Dim j&
Dim T()
Dim NoMetier As Boolean '///ajout
'--- Definition de la 1ère cellule du tableau Excel (Capabilité) ---
Set R = Range(FIRST_CELL_CAPABILITE)
'--- Efface le filtre (par défaut) ---
R.AutoFilter
'###########################
'### ListBox des Métiers ###
'###########################
Set LB = ActiveSheet.Shapes(LISTBOX_METIERS).OLEFormat.Object
'--- Les métiers qui ont été sélectionnés sont stockés dans une variable String ---
For i& = 1 To LB.ListCount
If LB.Selected(i&) Then LesMetiers$ = LesMetiers$ & LB.List(i&) & "µ"
Next i&
'--- Si au moins un métier a été sélectionné ---
If LesMetiers$ <> "" Then
'--- Split de la chaîne pour obtenir un tableau des métiers ---
Tbl = Split(LesMetiers$, "µ")
'--- On monte toutes les données de la feuille "Métiers" dans un Variant ---
var = Sheets("Métiers").[a1].CurrentRegion
For k& = 0 To UBound(Tbl) - 1 'boucle sur les métiers
For j& = 1 To UBound(var, 2) 'boucle sur les colonnes (concerne la feuille "Métiers")
If var(1, j&) = Tbl(k&) Then 'si on trouve une correspondance métier ...
For i& = 1 To UBound(var, 1) '... on boucle sur les lignes (concerne la feuille "Métiers") ...
If UCase(var(i&, j&)) = "X" Then '... si on y touve un X ...
On Error Resume Next '\\\Pour éviter les doublons
Coll.Add CStr(var(i&, 2)), CStr(var(i&, 2)) '... on l'ajoute à la collection.
On Error GoTo 0 '\\\Pour éviter les doublons (suite)
End If
Next i&
End If
Next j&
Next k&
'--- Si au moins un élément a été ajouté à la collection ---
If Coll.Count > 0 Then
'--- Transfert des éléments de la collection dans un tableau ---
ReDim T(1 To Coll.Count)
For i& = 1 To Coll.Count
T(i&) = Coll(i&)
Next i&
'--- Active le filtre en fonction des éléments du tableau (T) ---
R.CurrentRegion.AutoFilter Field:=2, Criteria1:=T, Operator:=xlFilterValues
End If
Else '///ajout
R.CurrentRegion.AutoFilter Field:=2, Criteria1:="", Operator:=xlFilterValues '///ajout
NoMetier = True '///ajout
End If
'############################
'### DropDown des Risques ###
'############################
Set DD = ActiveSheet.Shapes(DROPDOWN_RISQUES).OLEFormat.Object
'---
If DD.List(DD) <> "" Then
'--- Applique le filtre selon la valeur du DropDown ---
R.CurrentRegion.AutoFilter Field:=12, Criteria1:=DD.List(DD), Operator:=xlFilterValues
Else
'--- Pas de filtre, le DropDown est égal à RIEN (vide) ---
R.AutoFilter Field:=12
End If
If NoMetier Then DD.ListIndex = 1 '///ajout
'############################
'### DropDown des Rangs ###
'############################
Set DD = ActiveSheet.Shapes(DROPDOWN_RANGS).OLEFormat.Object
'---
If DD.List(DD) <> "" Then
'--- Applique le filtre selon la valeur du DropDown ---
R.CurrentRegion.AutoFilter Field:=13, Criteria1:=DD.List(DD), Operator:=xlFilterValues
Else
'--- Pas de filtre, le DropDown est égal à RIEN (vide) ---
R.AutoFilter Field:=13
End If
If NoMetier Then DD.ListIndex = 1 '///ajout
End Sub
Sub AfficherTout()
Dim i&
'--- ListBox des Métiers ---
Set LB = ActiveSheet.Shapes(LISTBOX_METIERS).OLEFormat.Object
For i& = 1 To LB.ListCount
If LB.Selected(i&) = True Then LB.Selected(i&) = False
Next i&
'--- DropDown des Risques ---
Set DD = ActiveSheet.Shapes(DROPDOWN_RISQUES).OLEFormat.Object
DD.ListIndex = 1
'--- DropDown des Rangs ---
Set DD = ActiveSheet.Shapes(DROPDOWN_RANGS).OLEFormat.Object
DD.ListIndex = 1
'--- Appel de la procédure de mise à jour ---
Call ListBox2Filtre
End Sub |
Filtrage de données via une matrice métiers
Répondre avec citation
: ça peut servir aux autres 
Partager