XL 2016 filtrer avec des cases a cocher :

youpi457032

XLDnaute Occasionnel
Bonjour,
J'ai besoin d'aide.
Je souhaite filtrer une base de données avec des critères activés ou non par case à cocher (CheckBox)
Dans mon classeur ce filtre existe déjà avec des champs zone de texte… (Userform FILTRE)
et la macro qui le fait fonctionner marche très bien :
la voici [\CODE]

'Macro Faite par …..
Option Explicit
Private Sub Bt1_Click()
Dim aa, i&, a&, fin&, col&, n&, Y&, bb, v&, X$
L2.Clear: X = "": Feuil7.Label1 = ""
fin = Feuil7.Cells.Find("*", , xlValues, , 1, 2, 0).Row
If fin < 2 Then fin = 2
Feuil3.Range("A2:Q" & fin).ClearContents
X = "Filtre pour recherche : "
For n = 0 To L1.ListCount - 1
If L1.Selected(n) Then
X = X & L1.List(n, 0) & ", "
End If
Next n
With Feuil6
fin = .Range("A" & Rows.Count).End(3).Row
If fin < 2 Then fin = 2
aa = .Range("A2:Q" & fin)
For i = 1 To UBound(aa)
For n = 0 To L1.ListCount - 1
If L1.Selected(n) Then
For col = 5 To 17
If aa(i, col) = L1.List(n, 0) Then ' POUR MOI c'est La que ca coince
aa(i, UBound(aa, 2)) = "oui": Y = Y + 1: GoTo 1
End If
Next col
End If
Next n
1 Next i
End With
If Y = 0 Then Exit Sub
If Y = 1 Then
ReDim bb(1 To 1, 1 To UBound(aa, 2) - 1)
For i = 1 To UBound(aa)
If aa(i, UBound(aa, 2)) = "oui" Then
For a = 1 To UBound(bb, 2)
bb(1, a) = aa(i, a)
Next a
End If
Next i
Else
ReDim bb(1 To Y, 1 To UBound(aa, 2) - 1): Y = 1
For i = 1 To UBound(aa)
If aa(i, UBound(aa, 2)) = "oui" Then
For a = 1 To UBound(bb, 2)
bb(Y, a) = aa(i, a)
Next a
Y = Y + 1
End If
Next i
End If
With L2
L2.ColumnCount = 13
L2.List = bb
End With
With Feuil6
.Cells(2, 1).Resize(UBound(bb), UBound(bb, 2)) = bb
.Label1 = Mid(X, 1, Len(X) - 2): .Label1.Font.Bold = 1
.Select
End With
End Sub
Private Sub Bt2_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
With L1
L1.List = Feuil2.Range("M2:M" & Feuil2.Range("M" & Rows.Count).End(3).Row).Value
L1.MultiSelect = 1
End With
End Sub
[/CODE]

j'ai essayé de fonctionner de la même manière avec des checkBox pour une autre utilité, mais forcément ça ne fonctionne pas puisque le résultat retourné n'est pas celui d'une Textbox.
Dans mon USERFORM FILTRE qui fonctionne, les valeurs des textBox sont comparées à celles d'une liste de référence (L1 de mon userform "Filtre"). Si les valeurs cibles de la feuille source sont identiques aux valeurs L1 sélectionnées, le Filtre fait son boulot, sinon rien...

Dans le cas que je soumets, vu qu'il s'agit non pas de Text box (qui renvoie une valeur strictement identique, à la valeur cible L1 recherchée), mais de CHECKBOX qui renvoie des résultats en "0" ou "-1", forcément çà ne fonctionne pas….
quelqu'un aurait il une idée pour corriger ma macro dans ce cas précis ?
Le code à corriger est en USERFORM "Filtre_manifestations" . Cet userfom travaille de concert avec les feuilles 6(manisfestations) et 7 (filtre manifestation)
Je joins le fichier a toute fin utile de compréhension...


Merci d'avance
 

Pièces jointes

  • malafretaz finalisé.xlsm
    248.4 KB · Affichages: 12
Dernière édition:

youpi457032

XLDnaute Occasionnel
Bonsoir,

Exemple de filtre avec cases à cocher.

Boisgontier
Merci de l'intérêt porté...
mais je souhaiterais rester sur mon filtre…. Il me sert ensuite à une macro mail...
Je pensais à une solution…. remplacer les valeurs "0" ou "-1" rendues par les cheCkbox par les valeurs des entêtes de colonnes (E1, F1...etc).
Ca me permettrait de retrouver le même résultat que rendu par mes texbox…. et du coup rester sur mon filtre….
Avez vous la solution pour affecter ligne après ligne une valeur rendue par une checkBox ?
Ex : la première colonne porte en E1 la valeur "GALA", pour chaque cellule de la colonne E & i (ligne)… renvoyer si coché "GALA", sinon rien…""
comme ca si la valeur rendue est GALA, je retrouve mon Filtre et ma macro qui fonctionne : Valeur "GALA" = "Reference L1 de mon filtre…. et ca fonctionne…. et je peux poursuivre ….
Merci d'avance
 

BOISGONTIER

XLDnaute Barbatruc
Repose en paix

Pièces jointes

  • Copie de FormFiltreCaseCocher-1.xls
    147.5 KB · Affichages: 16
Dernière édition:

siach

XLDnaute Nouveau
Bonjour,


>Je voudrais savoir si il y a moyen d'exporter les résultats affichés ou si on peut l'appliquer dans le feuille excel.

Je ne suis pas sûr de comprendre la question.

Cf PJ et


Boisgontier
Merci beaucoup à toi. C'est exactement ce que je voulais. Stp est-il possible d'aller à cinq ou plus de critères (par exemple dans le fichier envoyé c'est trois critères). Merci bien
 

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Bonsoir,

VB:
Dim f, NbCol, NomTableau, TblBD()
Private Sub UserForm_Initialize()
  NomTableau = "Tableau1"
  TblBD = Range(NomTableau).Value
  NbCol = UBound(TblBD, 2)
  Set d = CreateObject("scripting.dictionary")
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 3)) = ""
  Next i
  Me.ChoixListBox1.List = d.keys
  Set d = CreateObject("scripting.dictionary")
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 5)) = ""
  Next i
  Me.ChoixListBox2.List = d.keys
  Set d = CreateObject("scripting.dictionary")
  d.comparemode = vbTextCompare
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 6)) = ""
  Next i
  Me.ChoixListBox3.List = d.keys
  Set d = CreateObject("scripting.dictionary")
  d.comparemode = vbTextCompare
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 2)) = ""
  Next i
  Me.ChoixListBox4.List = d.keys
  Set d = CreateObject("scripting.dictionary")
  d.comparemode = vbTextCompare
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 7)) = ""
  Next i
  Me.ChoixListBox5.List = d.keys
  Me.ListBox1.ColumnCount = NbCol + 1
  Me.ListBox1.List = TblBD
  Range(NomTableau).ClearFormats
  EnteteListBox
End Sub

Sub EnteteListBox()
   x = Me.ListBox1.Left + 8
   Y = Me.ListBox1.Top - 20
   For c = 1 To NbCol
       Set Lab = Me.Controls.Add("Forms.Label.1")
       Lab.Caption = Range(NomTableau).Offset(-1).Item(1, c)
       Lab.ForeColor = vbBlack
       Lab.Top = Y
       Lab.Left = x
       Lab.Height = 24
       Lab.Width = Range(NomTableau).Columns(c).Width * 1#
       x = x + Range(NomTableau).Columns(c).Width * 1
       tempcol = tempcol & Range(NomTableau).Columns(c).Width * 1# & ";"
   Next c
   tempcol = tempcol
   On Error Resume Next
   Me.ListBox1.ColumnWidths = tempcol
   On Error GoTo 0
End Sub

Private Sub ChoixListBox1_change()
  Affiche
End Sub

Private Sub ChoixListBox2_change()
  Affiche
End Sub

Private Sub ChoixListBox3_change()
  Affiche
End Sub

Private Sub ChoixListBox4_change()
  Affiche
End Sub

Private Sub ChoixListBox5_change()
  Affiche
End Sub

Sub Affiche()
  Set dchoisis1 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox1.ListCount - 1
    If Me.ChoixListBox1.Selected(i) Then dchoisis1(Me.ChoixListBox1.List(i, 0)) = ""
  Next i
  Set dchoisis2 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox2.ListCount - 1
    If Me.ChoixListBox2.Selected(i) Then dchoisis2(Me.ChoixListBox2.List(i, 0)) = ""
  Next i
  Set dchoisis3 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox3.ListCount - 1
    If Me.ChoixListBox3.Selected(i) Then dchoisis3(Me.ChoixListBox3.List(i, 0)) = ""
  Next i
  Set dchoisis4 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox4.ListCount - 1
    If Me.ChoixListBox4.Selected(i) Then dchoisis4(Me.ChoixListBox4.List(i, 0)) = ""
  Next i
  Set dchoisis5 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox5.ListCount - 1
    If Me.ChoixListBox5.Selected(i) Then dchoisis5(Me.ChoixListBox5.List(i, 0)) = ""
  Next i
  n = 0: Dim Liste()
  For i = LBound(TblBD) To UBound(TblBD)
     tmp = TblBD(i, 3)
     tmp2 = TblBD(i, 5)
     tmp3 = TblBD(i, 6)
     tmp4 = TblBD(i, 2)
     tmp5 = TblBD(i, 7)
     If (dchoisis1.exists(tmp) Or dchoisis1.Count = 0) _
        And (dchoisis2.exists(tmp2) Or dchoisis2.Count = 0) _
         And (dchoisis3.exists(tmp3) Or dchoisis3.Count = 0) _
          And (dchoisis4.exists(tmp4) Or dchoisis4.Count = 0) _
            And (dchoisis5.exists(tmp5) Or dchoisis5.Count = 0) Then
         n = n + 1
         ReDim Preserve Liste(1 To NbCol + 1, 1 To n)
         For k = 1 To NbCol
            Liste(k, n) = TblBD(i, k)
         Next k
         Liste(k, n) = i
     End If
  Next i
  If n > 0 Then
    Me.ListBox1.Column = Liste
    Range(NomTableau).ClearFormats
    For i = 0 To Me.ListBox1.ListCount - 1
      ligne = Me.ListBox1.List(i, NbCol)
      Range(NomTableau).Cells(ligne, 1).Resize(, NbCol).Interior.ColorIndex = 4
    Next i
  Else
    Me.ListBox1.Clear
  End If
End Sub

Private Sub b_result_Click()
  [P2].Resize(100, NbCol + 1).ClearContents
  [P2].Resize(Me.ListBox1.ListCount, NbCol + 1) = Me.ListBox1.List
End Sub

Boisgontier
 

Pièces jointes

  • Copie de FormFiltreCaseCocher-1.xls
    72.5 KB · Affichages: 21
Dernière édition:

HervéDuval

XLDnaute Nouveau
Bonjour à toutes et à tous,
Je suis un nouveau membre et je recherche exactement ce que propose Boisgontier pour filtrer une base de données à partir de critères en cases à cocher. Est ce que je peux utiliser l'exemple ci dessus?
Le fichier semble vérouillé, faut-il que je créé une userform ou est ce que je peux utiliser celle-ci en changeant les libellés. Mais comment récupérer la userform?
Merci de vos réponses
Bonne journée
 

siach

XLDnaute Nouveau
Bonsoir,

VB:
Dim f, NbCol, NomTableau, TblBD()
Private Sub UserForm_Initialize()
  NomTableau = "Tableau1"
  TblBD = Range(NomTableau).Value
  NbCol = UBound(TblBD, 2)
  Set d = CreateObject("scripting.dictionary")
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 3)) = ""
  Next i
  Me.ChoixListBox1.List = d.keys
  Set d = CreateObject("scripting.dictionary")
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 5)) = ""
  Next i
  Me.ChoixListBox2.List = d.keys
  Set d = CreateObject("scripting.dictionary")
  d.comparemode = vbTextCompare
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 6)) = ""
  Next i
  Me.ChoixListBox3.List = d.keys
  Set d = CreateObject("scripting.dictionary")
  d.comparemode = vbTextCompare
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 2)) = ""
  Next i
  Me.ChoixListBox4.List = d.keys
  Set d = CreateObject("scripting.dictionary")
  d.comparemode = vbTextCompare
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 7)) = ""
  Next i
  Me.ChoixListBox5.List = d.keys
  Me.ListBox1.ColumnCount = NbCol + 1
  Me.ListBox1.List = TblBD
  Range(NomTableau).ClearFormats
  EnteteListBox
End Sub

Sub EnteteListBox()
   x = Me.ListBox1.Left + 8
   Y = Me.ListBox1.Top - 20
   For c = 1 To NbCol
       Set Lab = Me.Controls.Add("Forms.Label.1")
       Lab.Caption = Range(NomTableau).Offset(-1).Item(1, c)
       Lab.ForeColor = vbBlack
       Lab.Top = Y
       Lab.Left = x
       Lab.Height = 24
       Lab.Width = Range(NomTableau).Columns(c).Width * 1#
       x = x + Range(NomTableau).Columns(c).Width * 1
       tempcol = tempcol & Range(NomTableau).Columns(c).Width * 1# & ";"
   Next c
   tempcol = tempcol
   On Error Resume Next
   Me.ListBox1.ColumnWidths = tempcol
   On Error GoTo 0
End Sub

Private Sub ChoixListBox1_change()
  Affiche
End Sub

Private Sub ChoixListBox2_change()
  Affiche
End Sub

Private Sub ChoixListBox3_change()
  Affiche
End Sub

Private Sub ChoixListBox4_change()
  Affiche
End Sub

Private Sub ChoixListBox5_change()
  Affiche
End Sub

Sub Affiche()
  Set dchoisis1 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox1.ListCount - 1
    If Me.ChoixListBox1.Selected(i) Then dchoisis1(Me.ChoixListBox1.List(i, 0)) = ""
  Next i
  Set dchoisis2 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox2.ListCount - 1
    If Me.ChoixListBox2.Selected(i) Then dchoisis2(Me.ChoixListBox2.List(i, 0)) = ""
  Next i
  Set dchoisis3 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox3.ListCount - 1
    If Me.ChoixListBox3.Selected(i) Then dchoisis3(Me.ChoixListBox3.List(i, 0)) = ""
  Next i
  Set dchoisis4 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox4.ListCount - 1
    If Me.ChoixListBox4.Selected(i) Then dchoisis4(Me.ChoixListBox4.List(i, 0)) = ""
  Next i
  Set dchoisis5 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox5.ListCount - 1
    If Me.ChoixListBox5.Selected(i) Then dchoisis5(Me.ChoixListBox5.List(i, 0)) = ""
  Next i
  n = 0: Dim Liste()
  For i = LBound(TblBD) To UBound(TblBD)
     tmp = TblBD(i, 3)
     tmp2 = TblBD(i, 5)
     tmp3 = TblBD(i, 6)
     tmp4 = TblBD(i, 2)
     tmp5 = TblBD(i, 7)
     If (dchoisis1.exists(tmp) Or dchoisis1.Count = 0) _
        And (dchoisis2.exists(tmp2) Or dchoisis2.Count = 0) _
         And (dchoisis3.exists(tmp3) Or dchoisis3.Count = 0) _
          And (dchoisis4.exists(tmp4) Or dchoisis4.Count = 0) _
            And (dchoisis5.exists(tmp5) Or dchoisis5.Count = 0) Then
         n = n + 1
         ReDim Preserve Liste(1 To NbCol + 1, 1 To n)
         For k = 1 To NbCol
            Liste(k, n) = TblBD(i, k)
         Next k
         Liste(k, n) = i
     End If
  Next i
  If n > 0 Then
    Me.ListBox1.Column = Liste
    Range(NomTableau).ClearFormats
    For i = 0 To Me.ListBox1.ListCount - 1
      ligne = Me.ListBox1.List(i, NbCol)
      Range(NomTableau).Cells(ligne, 1).Resize(, NbCol).Interior.ColorIndex = 4
    Next i
  Else
    Me.ListBox1.Clear
  End If
End Sub

Private Sub b_result_Click()
  [P2].Resize(100, NbCol + 1).ClearContents
  [P2].Resize(Me.ListBox1.ListCount, NbCol + 1) = Me.ListBox1.List
End Sub

Boisgontier
Super super. Merci beaucoup
 

Discussions similaires

Réponses
5
Affichages
421
Réponses
4
Affichages
419

Statistiques des forums

Discussions
314 651
Messages
2 111 544
Membres
111 199
dernier inscrit
mavoungou regis