Discussion :

[nananinanana]

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Ben_L]

Bonjour à vous,

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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().

[nananinanana]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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.

[nananinanana]

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)
)

[Ben_L]

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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.