Filtre avancé avec des choix multiple à l'aide des CheckBox

Version imprimable

Bonjour,

J'ai un problème avec le filtre à choix multiple. Dans un Userform j'ai 6 CheckBox nommées (CheckBa,CheckBb,CheckBc,CheckBd,Checke,CheckBf)et j aimerai que lorsque je coche 2 checkBox voir plus, que le filte de ma base de données puise être appliqué.

je parviens pour l'instant à faire le filtre à l'aide d'une seule checkbox coché.
voici mon code:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Private Sub sendFormValuesToExcel()
    If (OptionS1) Then
        Range("J2").FormulaR1C1 = OptionS1.Caption
        If (CheckBa) Then
            Range("K2").FormulaR1C1 = "a"
        End If
    ElseIf (OptionS2) Then
         Range("J2").FormulaR1C1 = OptionS2.Caption
         'Range("K2").FormulaR1C1 = "a"
         'Range("P2").FormulaR1C1 = "b"
         'Range("P2").FormulaR1C1 = CheckBb.Caption
    End If
 
End Sub

Code:

1
2
3
4
Private Sub search()
    sendFormValuesToExcel
    Macrotrigroupe
End Sub

Code:

1
2
3
Private Sub OptionS1_Change()
    search
End Sub

Code:

1
2
3
Private Sub Cmdfiltre_Click()
    search
End Sub

Code:

1
2
3
4
5
6
7
8
9
10
11
12
Sub Macrotrigroupe()
'
' Macrotrigroupe Macro
'
 
'
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Range("Tableau14[#All]").AdvancedFilter Action:=xlFilterCopy, CriteriaRange _
        :=Range("I1:P2"), CopyToRange:=Range("I6:O6"), Unique:=False
End Sub

merci d'avance pour l'aide.

10/04/2019, 15h29
MarcelG

Bonjour Bell et bienvenu sur le Forum,

Remarques
- Pour le rendre plus accessible, tu peux baliser ton code par les bornes "#"
- Pour affecter une valeur à une cellule, mieux vaut utiliser la propriété Value que Formula

Pour ta problématique.
Tout d'abord consulter le tutoriel de Philipe à ce sujet
Dans ce cadre, tu peux nommer chaque cellule de ta zone de critères.
Celles-ci seraient alimentées par le formulaire
Le tutoriel comprend une partie VBA dont tu pourras t'inspirer
10/04/2019, 15h53
Bell2018

Bonjour MarcelG et merci pour les remarques,

J'aimerai préciser que j'ai déjà eu à parcourir le tuto indiqué, mais je reste sur ma faim. je précise bien que j'ai bien fait mon filtre avancé sur excel qui ma généré une macro par la suite.

je réussi aussi à faire le filtre à aide d'une seule checkbox coché, mais je veux que cela soit aussi possible lorsque le coche plusieurs checkbox.

ma base de données est constitué comme suit:
colonne A: matricule
colonne B: nom
colonne C: prénom
colonne D:groupe ( il existe 6 groupe de a-f) je représente ceci dans nom userform par des checkbox.
j'aimerai que en cochant les groupe a, d et f par exemple comme critère du tri, ma plage de résulta n'affiche que les individus appartenant à ce groupe.

j'espère que j'ai mieux exposé mon problème merci
11/04/2019, 09h12
MarcelG
Bonjour Bell, Bonjour au Forum,

Je reprends l'un des codes du tutoriel à un numéro de ligne près
Code:

1 2 3 4 5 6 Sub Filter() Range("A1:G16").AdvancedFilter _ Action:=xlFilterInPlace, _ CriteriaRange:=Range("I1:L4"), _ Unique:=False End Sub
(Pour l'instant, passons sur le rattachement des objets Range)

Ici la plage de critères est I1:L4.
Prenons l'une des cellules comprises dans ce Range. Exemple L3
Si la cellule L3 est nommée "lacheck_a" alors le code peut exécuter l'information de cette cellule.

Code:

If Chx_lacheck_a = True Then Range("lacheck_a").Value = "a"

Idem pour les autres cellule à informer au sein de la zone de critères.

Le filtre s'effectuera donc en fonction des valeurs de contrôles du formulaire.

Essaie d'adapter ton code en conséquence et reviens avec celui-ci dans son intégralité.

Bonjour MarrcelG et à tous,

En adaptant le code envoyé au mien, cela ne fonctionne:pleure: pas bref il y plus de tri en fonction de mes critères de choix c'est toute ma base de données qui est repris dans la zone du filtre choisi.

macro du filtre avancé

Code:

1
2
3
4
5
6
7
8
9
10
11
12
Sub tri_2()
'
' tri_2 Macro
'
 
'
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Range("Tableau14[#All]").AdvancedFilter Action:=xlFilterCopy, CriteriaRange _
        :=Range("I1:P5"), CopyToRange:=Range("I6:O6"), Unique:=False
End Sub

Code:

1
2
3
4
5
6
7
8
9
10
Private Sub sendFormValuesToExcel()
    If (OptionS1 = True) Then
        Range("J2").FormulaR1C1 = OptionS1.Caption
        If (CheckBa = True) Then Range("K2").Value = "a"
        If (CheckBb = True) Then Range("K3").Value = "b"
    ElseIf (OptionS2 = True) Then
         Range("J2").FormulaR1C1 = OptionS2.Caption
    End If
 
End Sub

11/04/2019, 10h50
MarcelG

Salut,

Très bien.
Joins un fichier sans données confidentielles.
11/04/2019, 11h59
Bell2018

1 pièce(s) jointe(s)

Bonjour MarcelG,

Voici mon fichier joins.
merci pour l'aide.

Pièce jointe 465746

Coucou Bell,

J'avais un professeur de mathématiques, en Terminale, qui faisait très souvent le parallèle entre un devoir de mathématiques et un devoir de français.
Il insistait notamment sur la clarté de l'exposé et le bon ordonnancement des méthodes.

Remarques:

1 - Comme partout ailleurs, la rigueur est nécessaire à la bonne nomenclature des contrôles.
Elle permet d'éviter les erreurs et, partant, d'envisager des boucles rendant le code à la fois plus souple et plus lisible. Comme ici.
Ainsi, j'ai renommé, entre autres, Chekc en CheckBc.
2 - Datevalue(Date) est redondant :)

Ici, j'ai créé 2 noms de cellules en J2 et K2.

Le code du formulaire ne se résume qu'à 3 procédures.

Tu remarqueras la valeur de la variable n qui a 2 objets:
- l'inscription des critères
- la définition de la zone de critères en fin de procédure

L'exécution du code est liée à l'activation du bouton de commande.

Tu consultes, tu comprends, tu appliques et tu reviens pour toute question.
J'ai enregistré le classeur. C'est volontairement que je ne te l'adresse pas, juste pour cet échange.
Code:

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 Option Explicit Private Sub UserForm_Initialize() txtdate.Value = Date End Sub Private Sub Cmdfiltre_Click() Call sendFormValuesToExcel End Sub Private Sub sendFormValuesToExcel() Dim n As Byte n = 0 Dim crit As Variant With Worksheets("données") .Range("I2:O8").ClearContents .Range("W9:AC10000").ClearContents For Each crit In Array("S1", "S2") If Controls("Option" & crit) = True Then .Range("crit_semestre").Value = crit Next crit For Each crit In Array("a", "b", "c", "d", "e", "f") If Controls("CheckB" & crit) = True Then n = n + 1 .Range("crit_groupe").Offset(n - 1).Value = crit End If Next crit .Range("Tableau1[#All]").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("I1").Resize(n + 1, 7), CopyToRange:=.Range("W9"), Unique:=False End With Unload Me End Sub

11/04/2019, 15h14
Bell2018

Salut MarcelG,

Merci pour les remarques.

J'ai appliqué ton code mais je n'ai toujours pas de tri:cry: sur la plage CopyToRange, c'est toute la base de données qui reportée là bas.

Merci

1 pièce(s) jointe(s)

Bonjour,

Exemple de groupe d'options multiples avec ListBox

Code:

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
Option Compare Text
Dim TblBD()
Private Sub UserForm_Initialize()
  TblBD = [client].Value     ' pour rapidité
  TriMultiCol TblBD, 1, UBound(TblBD), 2
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To [client].Rows.Count
    tmp = TblBD(i, 3): d(tmp) = ""
  Next i
  Me.OptionsGroupe.ListStyle = 1 'frmliststyleoption
  Tbl = d.keys
  Tri Tbl, LBound(Tbl), UBound(Tbl)
  Me.OptionsGroupe.List = Tbl
  Me.ListBox1.ColumnCount = [client].Columns.Count + 1
  Me.ListBox1.ColumnWidths = "60;50;30;50;100;70;70;50"
  Me.ListBox1.List = TblBD
End Sub
 
Private Sub OptionsGroupe_change()
  Set dchoisis1 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.OptionsGroupe.ListCount - 1
    If Me.OptionsGroupe.Selected(i) Then dchoisis1(Me.OptionsGroupe.List(i, 0)) = ""
  Next i
  Dim Tbl2(): n = 0: Ncol = UBound(TblBD, 2)
  For i = 1 To UBound(TblBD)
    tmp = TblBD(i, 3)
    If dchoisis1.exists(tmp) Then
        n = n + 1: ReDim Preserve Tbl2(1 To Ncol, 1 To n)
        For k = 1 To Ncol: Tbl2(k, n) = TblBD(i, k): Next k
    End If
  Next i
  If n > 0 Then Me.ListBox1.Column = Tbl2 Else Me.ListBox1.Clear
End Sub

Boisgontier

11/04/2019, 15h33
Bell2018

Bonjour boisgontierjacques,

merci déjà pour ton aide car c'est ce résultat que je recherche, mais avec la manière dont mon fichier est conçu.
Si tu pouvais me guider avec mon fichier, ça m'enlèverai un grand poids à mon projet.
11/04/2019, 15h43
MarcelG

Salut Jacques,

Comme Bell avait comme point de départ un filtre élaboré, j'ai développé en ce sens.
En tout cas, :plusser:

Bell,
Je n'ai pas évoqué le tri.
Il n'y a donc pas matière à désespérer.

Avec le code que je t'ai proposé, le filtre s'exécute-t-il convenablement?
Des questions?
Pour le tri, tu peux t'aider de l'enregistreur de macro, à condition de l'épurer au maximum.

Reviens si nécessaire.
Le but est que tu intègres toutes les méthodes et propriétés incluses dans le code.

A plus. A moins que tu décides de naviguer vers d'autres cieux..., ce en quoi je ne verrais pas d'inconvénient. Tant pis pour moi.
11/04/2019, 15h53
Bell2018

En effet MarcelG le filtre n'est pas élaboré, car après que j'ai coché mes critères de filtre , je n'observe rien d'où mon véritable problème
11/04/2019, 16h00
MarcelG

1 pièce(s) jointe(s)

Tu peux m'apostropher par "Marcel" ("G" est l'initiale de mon nom)

Citation:

le filtre n'est pas élaboré

Si, si, il l'est.:):):)
C'est son exécution qui n'aboutit pas.

Je t'adresse le fichier en pièce jointe.
Surtout, tu comprends tout ce qui est reporté dans le code (méthodes et propriétés).

Reviens si nécessaire.

1 pièce(s) jointe(s)

Avec un groupe dynamique, on peut ajouter des groupes sans modifier le formulaire.
Faire une intersection de 2 listes avec le filtre élaboré est compliqué.

Code:

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
Option Compare Text
Dim TblBD(), dchoisis1, dchoisis2
Private Sub UserForm_Initialize()
  TblBD = [client].Value     ' pour rapidité
  TriMultiCol TblBD, 1, UBound(TblBD), 3
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To [client].Rows.Count
    tmp = TblBD(i, 3): d(tmp) = ""
  Next i
  Me.OptionsGroupe.MultiSelect = fmMultiSelectMulti
  Me.OptionsGroupe.ListStyle = 1 'frmliststyleoption
  Tbl = d.keys
  Tri Tbl, LBound(Tbl), UBound(Tbl)
  Me.OptionsGroupe.List = Tbl
  '--
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To [client].Rows.Count
    tmp = TblBD(i, 2): d(tmp) = ""
  Next i
  Me.OptionsSem.MultiSelect = fmMultiSelectMulti
  Me.OptionsSem.ListStyle = 1 'frmliststyleoption
  Me.OptionsSem.List = d.keys
  '--
  Me.ListBox1.ColumnCount = [client].Columns.Count + 1
  Me.ListBox1.ColumnWidths = "60;50;30;50;100;70;70;50"
  Me.ListBox1.List = TblBD
End Sub
 
Private Sub OptionsGroupe_change()
  Affiche
End Sub
 
Private Sub OptionsSem_change()
  Affiche
End Sub
 
Sub Affiche()
  Set dchoisis1 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.OptionsGroupe.ListCount - 1
    If Me.OptionsGroupe.Selected(i) Then dchoisis1(Me.OptionsGroupe.List(i, 0)) = ""
  Next i
  Set dchoisis2 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.OptionsSem.ListCount - 1
    If Me.OptionsSem.Selected(i) Then dchoisis2(Me.OptionsSem.List(i, 0)) = ""
  Next i
  Dim Tbl2(): n = 0: Ncol = UBound(TblBD, 2)
  For i = 1 To UBound(TblBD)
    tmp = TblBD(i, 3): tmp2 = TblBD(i, 2)
    If dchoisis1.exists(tmp) And dchoisis2.exists(tmp2) Then
        n = n + 1: ReDim Preserve Tbl2(1 To Ncol, 1 To n)
        For k = 1 To Ncol: Tbl2(k, n) = TblBD(i, k): Next k
    End If
  Next i
  If n > 0 Then Me.ListBox1.Column = Tbl2 Else Me.ListBox1.Clear
End Sub

Boisgontier

11/04/2019, 16h39
MarcelG

Cela dépasse l'entendement.

Preuve, s'il en est, que la technicité n'est pas forcément reflétée par la qualité quantifiée de l'intervenant.
Pour preuve
- MarcelG = Expert confirmé
- Jacques Boisgontier = Membre Chevronné

Alors que, comme on dit, "il n'y a pas photo".
11/04/2019, 17h56
Bell2018

merci Jacques,Marcel, j'ai trouvé mon erreur finalement qui était au niveau de la plage de réception du filtre.

Cependant j'ai une autre préoccupation le filtre s'exécute bien au niveau des groupes mais pas des semestres.

car lorsque je coche "S1" et "groupe a", "groupe b" j'ai tous les étudiants appartenant à ses groupes des" S1"et "S2", alors que je veux juste ceux de "S1"

1 pièce(s) jointe(s)

Une façon simple avec le filtre auto.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
Sub Filtre()
  Application.ScreenUpdating = False
  On Error Resume Next
  ActiveSheet.ShowAllData
   '--- groupe
   n = Application.CountA([C2:C8])
   If n > 0 Then
     Tbl = Application.Transpose([C2].Resize(n))
     ActiveSheet.[A10].AutoFilter Field:=3, Criteria1:=Tbl, Operator:=xlFilterValues
   End If
   '--- semestre
   n = Application.CountA([b2:B3])
   If n > 0 Then
     Tbl = Application.Transpose([b2].Resize(n))
     ActiveSheet.[A10].AutoFilter Field:=2, Criteria1:=Tbl, Operator:=xlFilterValues
   End If
End Sub

Boisgontier

Fuseau horaire GMT +2. Il est actuellement 11h07.