Filtres horizontaux multicritères avec userform

Version imprimable

1 pièce(s) jointe(s)

Bonjour à tous,

Je souhaiterai pourvoir effectuer des filtres horizontaux, multicritères à l'aide d'un userform et d'un champ recherche

La première partie de code permet de rechercher un fichier, je souhaite pouvoir sélectionner plusieurs item et que lorsque je recherche un item je puisse avoir le choix (ajouter à la selection ou filtrer avec, un peu comme le filtre vertical déjà par défaut)

Or cette première partie de code ne permet pas d'ajouter à la une selection une fois que j'efface le textbox la listbox se réinitialise,

aussi pour masquer les colonnes mon essai était beaucoup trop long et faisait planter l'application, Y a-t-il une solution autre que de passer par for i = .. to ... if tab<>listbox then cellshiddencolumn=true (en gros)

Merci d'avance

Pièce jointe 248915
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 Option Compare Text Private Sub TextBox2_Change() Dim derl% derl = Worksheets("GMD").Cells(Rows.Count, 2).End(xlUp).Row Application.ScreenUpdating = False If TextBox2 <> "" Then ListBox2.Clear For Ligne = 7 To derl If Cells(Ligne, 2) Like "*" & TextBox2 & "*" Then ListBox2.AddItem Cells(Ligne, 2) 'Exemple 2 (ListBox) End If Next End If End Sub Private Sub CommandButton2_Click() Unload Me End Sub Private Sub ListBox2_Click() End Sub
J'ai initialisé mon userforme avec des données de mon fichier
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 Private Sub UserForm_Initialize() Dim cell1 As Range Dim Unique1 As New Collection Dim Valeur1 Dim i As Integer Dim derl% i = Worksheets("GMD").Cells(Rows.Count, 2).End(xlUp).Row On Error Resume Next 'boucle sur les Cell1ules de la colonne A For Each cell1 In Worksheets("gmd").Range("B7:B" & i) 'Stocke les données dans une collection '(La collection n'accepte que des données uniques et permet donc ' de filtrer facilement les doublons). If cell1 <> "" Then Unique1.Add cell1, CStr(cell1) End If Next cell1 On Error GoTo 0 'Boucle sur le contenu de la collection pour alimenter la ListBox For Each Valeur1 In Unique1 Me.ListBox2.AddItem Valeur1 Me.ListBox2.MultiSelect = fmMultiSelectMulti Me.ListBox2.ListStyle = fmListStyleOption Next Valeur1 Set Unique1 = Nothing End Sub

27/02/2017, 15h49
Ben_L
Bonjour à vous,

Il me semble que le plus simple est d'utiliser la fonction Filter().
Code:

1 2 Arr = Array("String_1", "String_2", "Chaine_1", "Chaine_2", "String_3") ListBox2.List = Filter(Arr, "Chaine")
La liste complète doit être stockée dans une variable globale, lors de l'initialisation de la Userform.
La réaffectation de la liste de ListBox2 est à inclure dans la procédure TextBox2_Change().

Listbox 3 servira à filtre et la listbox 2 est initialisé avec le fichier,

les critères seront ceux de la listbox 3, je vais essayer de voir comment utiliser la fonction filtre merci

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
Private Sub CommandButton3_Click()
Dim Unique As New Collection
Dim Valeur
Dim i As Integer
 
On Error Resume Next
If ListBox2.ListIndex = -1 Then Exit Sub
For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) = True Then
Unique.Add Me.ListBox2.List(i), CStr(Me.ListBox2.List(i))
ListBox2.RemoveItem (i)
End If
Next
 
For Each Valeur In Unique
Me.ListBox3.AddItem Valeur
Me.ListBox3.MultiSelect = fmMultiSelectMulti
Me.ListBox3.ListStyle = fmListStyleOption
Next Valeur
 
On Error GoTo 0
 
Set Unique = Nothing
End Sub

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
Private Sub CommandButton4_Click()
Dim Unique As New Collection
Dim Valeur
Dim i As Integer
 
On Error Resume Next
If ListBox3.ListIndex = -1 Then Exit Sub
For i = 0 To ListBox2.ListCount - 1
If ListBox3.Selected(i) = True Then
Unique.Add Me.ListBox3.List(i), CStr(Me.ListBox3.List(i))
ListBox3.RemoveItem (i)
End If
Next
 
For Each Valeur In Unique
Me.ListBox2.AddItem Valeur
Me.ListBox2.MultiSelect = fmMultiSelectMulti
Me.ListBox2.ListStyle = fmListStyleOption
Next Valeur
 
On Error GoTo 0
 
Set Unique = Nothing
End Sub

27/02/2017, 17h21
Ben_L

Je n'arrive pas à comprendre votre besoin.
¤ Pourquoi des codes si proches pour les 2 CommandButton alors que votre image montre un bouton "Filtrer" et un bouton "Annuler" ?
¤ A quoi sert la TextBox "Rechercher" ?
¤ Plus généralement :
- Où se situe l'information à filtrer ?
- Où doit aller l'information filtrée ?
- Où trouve-t-on la chaîne de caractère qui sert de filtre ?

Enfin, l'utilisation de noms plus évocateurs pour vos contrôles faciliterait l'appropriation du code par une tierce personne.
28/02/2017, 07h44
nananinanana

1 pièce(s) jointe(s)

J'ai légèrement modifié mon userform j'ai rajouté des boutons pour transférer d'une listbox à une autre,
le textbox "Rechercher" permet de rechercher les élements dans la première listbox car il y en a vraiment beaucoup,

En selectionnant et en cliquant sur le bouton ">>" je le fait passer dans la deuxième listbox qui est celle dont je veux me servir pour filtrer horizontalement

L'information à filtrer sur mon fichier se trouve ligne 2 et sont initialisées dans ma 1ère listbox (de gauche)
)
Pièce jointe 249109

Merci pour ces précisions.
Ci-dessous une proposition de code :

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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
Option Explicit
 
Private CompleteList As Variant
 
Private Sub UserForm_Initialize()
    With ThisWorkbook.Sheets("Feuil1")
         CompleteList = Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlToRight)).Value)
         Me.LBxDocs.ColumnCount = 1
         Me.LBxDocs.List = CompleteList
    End With
End Sub
 
 
Private Sub TBxSearch_Change()
    Dim TmpArr As Variant
    TmpArr = Filter(Application.Transpose(CompleteList), Me.TBxSearch.Text)
    If Len(Join(TmpArr)) <> 0 Then
        Me.LBxDocs.List = Application.Transpose(TmpArr)
    Else
        Me.LBxDocs.Clear
    End If
End Sub
 
 
Private Sub BtnSelect_Click()
    Dim NewDoc As String, Itm As Variant
    If Me.LBxDocs.ListIndex <> -1 Then
        NewDoc = Me.LBxDocs.List(Me.LBxDocs.ListIndex)
        If Me.LBxSelect.ListCount > 0 Then
            For Each Itm In Me.LBxSelect.List
                If Itm = NewDoc Then Exit Sub
            Next Itm
        End If
        Me.LBxSelect.AddItem NewDoc
    End If
End Sub
 
 
Private Sub BtnUnselect_Click()
    If Me.LBxSelect.ListIndex <> -1 Then
        Me.LBxSelect.RemoveItem Me.LBxSelect.ListIndex
    End If
End Sub
 
 
Private Sub BtnFiltre_Click()
    Dim i As Long
    With ThisWorkbook.Sheets("Feuil1")
        .Cells.EntireColumn.Hidden = False
        i = 1
        Do While .Cells(2, i).Text <> ""
            If Not ValueInList(.Cells(2, i).Text, Me.LBxSelect.List) Then
                .Columns(i).EntireColumn.Hidden = True
            End If
            i = i + 1
        Loop
    End With
    Unload Me
End Sub
 
 
Private Sub BtnAnnul_Click()
    Unload Me
End Sub
 
 
Private Function ValueInList(Val As String, List As Variant) As Boolean
    Dim Itm As Variant
    ValueInList = True
    For Each Itm In List
        If Val = Itm Then Exit Function
    Next Itm
    ValueInList = False
End Function

Le code ci-dessus suppose que la feuille à filtrer se nomme Feuil1, et que les données présentes dans la ligne 2 sont contigües (pas de cellule vide).
C'est très basique, mais ça peut faire une base.

28/02/2017, 13h47
nananinanana

Merci beaucoup !

C'est exactement ce que je cherchais à faire à quelques choses près, les colonnes 1 à 6 ne doivent pas être masquées ce pourquoi je pense je reçois une erreur ligne 49 (impossible de définir la propriété Hidden),

Aussi les cellules les documents à initialiser sont colonnes 7 à dernière colonne, j'ai donc changer le numéro des cellules ".Cells(2, 7)" au lieu de ".Cells(2, 1)"

Et Enfin j'aurais aimé que le textbox ne soit pas sensible à la casse

Pour éviter de masquer les colonnes 1 à 6, il suffit, dans BtnFiltre_Click(), de remplacer la ligne d'initialisation de la variable i par :

Code:

i = 7

Et pour que le TextBox ne soit pas sensible à la casse, vous pouvez redéfinir la fonction ValueInList comme suit :
Code:

1 2 3 4 5 6 7 8 Private Function ValueInList(Val As String, List As Variant) As Boolean Dim Itm As Variant ValueInList = True For Each Itm In List If Val = LCase(Itm) Then Exit Function Next Itm ValueInList = False End Function
et appeler cette fonction de la façon suivante :

Code:

ValueInList(LCase(.Cells(2, i).Text), Me.LBxSelect.List)

28/02/2017, 14h12
nananinanana

Merci pour le filtre ça fonctionne, mais c'est très très long ! Est-ce possible de passer par un tableau pour définir les colonnes à filtrer ? (parraît que ça va plus vite)

Avec les codes il est toujours sensible aux minuscules et donc ne trouve pas le document sauf si j'écris en majuscule

Pour accélérer le code, le plus simple est de commencer par ajouter, au début et à la fin de la procédure BtnFiltre_Click() les lignes suivantes :
Code:

1 2 3 Application.ScreenUpdating = False <...> Application.ScreenUpdating = True
Si c'est toujours beaucoup trop long, alors il faudra peut-être envisager d'autres astuces.

Pour la casse, je ne vois vraiment pas pour quelle raison elle serait encore prise en compte.
La sensibilité à la casse est-elle liée à ce qui doit se passer après appui sur le bouton 'Filtrer', ou lorsque vous modifiez le contenu de la TextBox ?
Si c'est lié à la recherche via la Textbox, modifiez la procédure comme suit :
Code:

1 2 3 4 5 6 7 8 Private Sub TBxSearch_Change() Dim Itm As Variant, SearchText as String Me.LBxDocs.Clear SearchText = LCase(Me.TBxSearch.Text) For Each Itm in CompleteList If InStr(LCase(Itm), SearchText) > 0 Then Me.LBxDocs.AddItem Itm Next Itm End Sub

28/02/2017, 15h27
nananinanana

Merci !! tout fonctionne !

Juste un dernier petit truc, si je clique sur "filtrer" alors que je n'ai rien selectionné un message d'erreur s'affiche, il y aurait un moyen de contourner cela ?

EDIT :
avec on error resume next dans la fonction cela fonctionne !

Encore merci !!!