VBA ListBox avec recherche multicritéres

Version imprimable

Voir 40 message(s) de cette discussion en une page

1 pièce(s) jointe(s)

VBA ListBox avec recherche multicritéres

Bonjour,

J'ai un tableau avec une liste de pièces (1000 pièces). Le tableau à une seule colonne avec tous les détails des pièces.

A la sélection d'une cellule la Userform s'affiche, je fais ma première recherche via la TextBox1 avec le critére "attac", la liste se réduit, jusque la pas de problème.

J'aimerai pouvoir affiner la rechreche avec le texte afficher via la TextBox2 avec le critére "EM" et pouvoir encore affiner la rechreche avec le texte afficher, via la TextBox3 avec le critére "3"

Voici le code et une image de l'UserForm

Merci pour votre aide et excellent week-end

Philippe
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 Dim a Private Sub UserForm_Initialize() a = [Liste_Pieces].Value Me.ListBox1.List = a Me.Search_dans_tous_les_mots.SetFocus 'Place le curseur dans la textbox End Sub Private Sub Search_dans_tous_les_mots_Change() Set D1 = CreateObject("Scripting.Dictionary") Me.ListBox1.Clear tmp = "*" & UCase(Me.Search_dans_tous_les_mots) & "*" For Each C In a If UCase(C) Like tmp Then D1(C) = "" Next C Me.ListBox1.List = D1.keys End Sub 'Private Sub Search_premiere_lettre_change() ' Set D1 = CreateObject("Scripting.Dictionary") ' Me.ListBox1.Clear ' tmp = UCase(Me.Search_premiere_lettre) & "*" ' For Each C In a ' If UCase(C) Like tmp Then D1(C) = "" ' Next C ' Me.ListBox1.List = D1.keys 'End Sub Private Sub ListBox1_Click() ActiveCell = Me.ListBox1 Unload Me End Sub

Bonjour,

J'opterais pour ADODB et traiter tes données comme une table de base de données.

Dans l'exemple suivant, 3 textbox et une listbox nommées par défaut.
La feuille qui contient les données se nomme Feuil1 et celle qui reçoit les données "filtrées" est Feuil2. Ces données servent à remplir la listbox.
Il faut aussi ajouter une référence à Microsoft ActiveX Data Objects X.X Library (version la plus récente)

Disons que j'ai fait ça assez rapidement sans trop réfléchir...
Il y a sûrement des améliorations à y apporter.

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
75
76
77
78
79
80
81
82
83
84
85
86
Dim Cn As ADODB.Connection

Private Sub TextBox1_AfterUpdate()
    Dim nbLignes As Long
    Dim Rs As ADODB.Recordset
    Dim strSQL As String
    
    Sheets("Feuil2").Cells.Clear
    
    Set Rs = New ADODB.Recordset
    Rs.CursorLocation = adUseClient
    
    strSQL = "SELECT * FROM [Feuil1$] where [TitreDeLaColonne] like '%" & Me.TextBox1 & "%'"
    Rs.Open strSQL, Cn, adOpenDynamic
    If Rs.RecordCount > 0 Then Sheets("Feuil2").Range("A1").CopyFromRecordset Rs
    
    nbLignes = Sheets("Feuil2").Cells(Rows.Count, "A").End(xlUp).Row
    Me.ListBox1.List = Sheets("Feuil2").Range("A1:A" & nbLignes).Value
    
    Rs.Close
    Set Rs = Nothing

End Sub

Private Sub TextBox2_AfterUpdate()
    Dim nbLignes As Long
    Dim Rs As ADODB.Recordset
    Dim strSQL As String
    
    Sheets("Feuil2").Cells.Clear
    
    Set Rs = New ADODB.Recordset
    Rs.CursorLocation = adUseClient
    
    strSQL = "SELECT * FROM [Feuil1$] where [TitreDeLaColonne] like '%" & Me.TextBox1 & _
             "%' and [TitreDeLaColonne] like '%" & Me.TextBox2 & "%'"
    Rs.Open strSQL, Cn, adOpenDynamic
    If Rs.RecordCount > 0 Then Sheets("Feuil2").Range("A1").CopyFromRecordset Rs
    
    nbLignes = Sheets("Feuil2").Cells(Rows.Count, "A").End(xlUp).Row
    Me.ListBox1.List = Sheets("Feuil2").Range("A1:A" & nbLignes).Value
    
    Rs.Close
    Set Rs = Nothing
End Sub

Private Sub TextBox3_AfterUpdate()
    Dim nbLignes As Long
    Dim Rs As ADODB.Recordset
    Dim strSQL As String
    
    Sheets("Feuil2").Cells.Clear
    
    Set Rs = New ADODB.Recordset
    Rs.CursorLocation = adUseClient
    
    strSQL = "SELECT * FROM [Feuil1$] where [TitreDeLaColonne] like '%" & Me.TextBox1 & _
             "%' and [TitreDeLaColonne] like '%" & Me.TextBox2 & _
             "%' and [TitreDeLaColonne] like '%" & Me.TextBox3 & "%'"
    Rs.Open strSQL, Cn, adOpenDynamic
    If Rs.RecordCount > 0 Then Sheets("Feuil2").Range("A1").CopyFromRecordset Rs
    
    nbLignes = Sheets("Feuil2").Cells(Rows.Count, "A").End(xlUp).Row
    Me.ListBox1.List = Sheets("Feuil2").Range("A1:A" & nbLignes).Value
    
    Rs.Close
    Set Rs = Nothing
End Sub

Private Sub UserForm_Initialize()
    Set Cn = New ADODB.Connection

    With Cn
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
            & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=yes;IMEX:=1"""
        .Open
    End With
    TextBox1.SetFocus
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If Not Cn Is Nothing Then
        Cn.Close
    End If
    Set Cn = Nothing
End Sub

28/10/2016, 17h43
goninph

1 pièce(s) jointe(s)

Bonjour,

Merci pour la réponse. AU clique de la cellule, l'erreur suivante s'affiche :
28/10/2016, 18h09
joe.levrai

Bonjour,

as-tu respecté la consigne de parmi :

Citation:

Il faut aussi ajouter une référence à Microsoft ActiveX Data Objects X.X Library (version la plus récente)

si tu n'as pas coché la référence, alors VBA ne connait pas ces variables
sinon tu seras obligé de travailler en liaison tardive qui ne nécessite pas la référence adéquate.
28/10/2016, 18h43
goninph

Bonjour,

Question : est-il possible de rechercher plusieurs mots avec la même TextBox en ajoutant ente les mots un + ou un * ou que sais-je ?

Merci

Philippe

En me penchant sur ton besoin, je me demande s'il est bien nécessaire de passer par une requête

voici un exemple valant proposition différente

j'alimente ListBox1 par la plage contigüe démarrant en A1 de la feuille active
les trois textbox qui servent de zone de critère sont TextBox1 / TextBox2 / TextBox3
==> je te laisse donc adapter ceci, le nom des textbox ne doit pas être modifié, sinon il faut modifier un peu la procédure de filtrage

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
Option Compare Text
Dim a
 
' ICI ON APPELLE JUSTE LA METHODE GLOBALE DE FILTRAGE
Private Sub TextBox1_Change()
    FiltreMonListBox Me.ListBox1
End Sub
 
Private Sub TextBox2_Change()
    FiltreMonListBox Me.ListBox1
End Sub
 
Private Sub TextBox3_Change()
    FiltreMonListBox Me.ListBox1
End Sub
 
' ICI ON CREE LE TABLEAU DE TOUS LES ELEMENTS
' ET ON APPELLE LA METHODE DE REMPLISSAGE
Private Sub UserForm_Initialize()
a = Cells(1, 1).CurrentRegion.Value
RempliMonListBox Me.ListBox1
End Sub
 
 
' LA METHODE QUI EFFECTUE LE FILTRAGE
Private Sub FiltreMonListBox(LeListBox As msforms.ListBox)
Dim LesFiltres As String, Nb_Filtres As Long
    ' vidage et remplissage complet
    RempliMonListBox LeListBox
 
    ' on prend le critère de filtrage de chacune des trois textbox (si elle ne sont pas vides
    For i = 1 To 3
        If Me.Controls("TextBox" & i).Text <> "" Then LesFiltres = Me.Controls("TextBox" & i).Text & "$" & LesFiltres
    Next i
 
    ' on regarde combien de critères à analyser
    Nb_Filtres = UBound(Split(LesFiltres, "$"))
 
    ' s'il y a des critères
    If Nb_Filtres > 0 Then
        With LeListBox
            ' pour chaque élément de ListBox
            For j = .ListCount To 1 Step -1
                ' pour chaque filtrage souhaité
                For i = 0 To Nb_Filtres - 1
                    ' on regarde si le critère de filtrage existe dans l'élément de ListBox testé
                    If Not ExisteDans(Split(LesFiltres, "$")(i), .List(j - 1)) Then
                        ' s'il n'existe pas, on supprime l'élément
                        .RemoveItem (j - 1)
                        Exit For
                    End If
                Next i
            Next j
        End With
    End If
End Sub
 
 
' VIDAGE ET REMPLISSAGE DU LISTBOX
Private Sub RempliMonListBox(LeListBox As msforms.ListBox)
    With LeListBox
        .Clear
        .List = a
    End With
End Sub
 
' FONCTION QUI VERIFIE SI UNE SOUS-CHAINE EXISTE DANS UNE CHAINE
Function ExisteDans(ByVal LaChaine As String, ByVal ItemDuListBox As String) As Boolean
    ExisteDans = InStr(1, ItemDuListBox, LaChaine) > 0
End Function

28/10/2016, 19h35
parmi

Citation:

Envoyé par goninph

Bonjour,

Question : est-il possible de rechercher plusieurs mots avec la même TextBox en ajoutant ente les mots un + ou un * ou que sais-je ?

Merci

Philippe

Oui, tout dépend de la façon dont tu procèdes.
Si on part de mon exemple, tu peux effectuer un Split (voir aide) sur le caractère que tu choisis comme séparateur.

Code:

Tablo = Split(Textbox1, "+")

Tu te retrouves donc avec autant de critères que tu as choisis.... Tablo(0), Tablo(1),...
Il suffit alors de créer ta requête SQL en bouclant ce tableau.

2 pièce(s) jointe(s)

Bonour,

Le textbox/listbox peut être remplacé par un simple ComboBox.
Les mots recherchés peuvent être saisis dans un ordre quelconque.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 
Dim f, choix()
Private Sub UserForm_Initialize()
   Set f = Sheets("bd")
   Set Rng = f.Range("a2:a" & f.[A65000].End(xlUp).Row)
   choix = Application.Transpose(Rng)
   Me.ComboBox1.List = choix
End Sub
 
Private Sub ComboBox1_Change()
 If Me.ComboBox1 <> "" And IsError(Application.Match(Me.ComboBox1, choix, 0)) Then
   mots = Split(Trim(Me.ComboBox1), " ")
   tbl = choix
   For i = LBound(mots) To UBound(mots)
     tbl = Filter(tbl, mots(i), True, vbTextCompare)
   Next i
   Me.ComboBox1.List = tbl
   Me.ComboBox1.DropDown
 Else
   ComboBox1_Click
 End If
End Sub

Version avec Textbox/ListBox

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
Dim f, choix()
Private Sub UserForm_Initialize()
   Set f = Sheets("bd")
   Set Rng = f.Range("a2:a" & f.[A65000].End(xlUp).Row)
   choix = Application.Transpose(Rng)
   Me.ListBox1.List = choix
End Sub
 
Private Sub TextBox1_Change()
   mots = Split(Trim(Me.TextBox1), " ")
   tbl = choix
   For i = LBound(mots) To UBound(mots)
     tbl = Filter(tbl, mots(i), True, vbTextCompare)
   Next i
   Me.ListBox1.List = tbl
End Sub

Boisgontier

Bonjour
Je laisse analyser, comprendre, deviner et utiliser l'action de ceci :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Private Sub CommandButton1_Click() MsgBox voir_si("abcdefgh", "AND/*aeb*/*c*") MsgBox voir_si("abcdefgh", "AND/*ab*/*c*/*g*") MsgBox voir_si("abcdefgh", "OR/?bc*/*cd*/*g?") End Sub Private Function voir_si(c As String, r As String) As Boolean Dim n As Integer, f As Variant f = Split(r, "/") n = 0 For i = 1 To UBound(f) n = n + Abs(CInt(c Like f(i))) If f(0) = "OR" And n > 0 Then voir_si = True: Exit Function Next voir_si = n > UBound(f) - 1 End Function
Il ne s'agit en fait là que d'une simplification/réduction d'un code bien plus complexe (et long) que j'avais écrit à l'époque pour permettre l'utilisation d'une base de données comme le faisait INFORMIX sous Unix (le même écran servait à modifier, ajouter, supprimer, etc ... et faire des requêtes directes et en afficher les résultats)

Bonjour,

Merci Monsieur boisgontierjacques, c'est exactement ce que je cherche.

J'ai modifié le code pour l'adapter à mon fichier, mais je n'arrive pas à le modifier pour travailler avec un nom de liste sachant que la liste ne comporte qu'une colonne.

Votre aide serait la bienvenue

Le nom de liste est [Liste_Pieces].Value

Merci et bon week-end

Philippe
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 Dim f, choix() Private Sub UserForm_Initialize() Set f = Sheets("Data Pieces") Set Rng = f.Range("H4:H" & f.[A65000].End(xlUp).Row) choix = Application.Transpose(Rng) Me.ListBox1.List = choix End Sub Private Sub TextBox1_Change() mots = Split(Trim(Me.TextBox1), " ") tbl = choix For i = LBound(mots) To UBound(mots) tbl = Filter(tbl, mots(i), True, vbTextCompare) Next i Me.ListBox1.List = tbl End Sub Private Sub ListBox1_Click() Set Rng = f.Range("H4:H" & f.[A65000].End(xlUp).Row) Set result = Rng.Find(what:=Me.ListBox1) ActiveCell = Me.ListBox1 Unload Me End Sub

Bonjour,

Mille merci, c'est tout bon, j'ai pu adapter le code à mon fichier et en fait le code : f.Range("H4:H" & f.[H65000].End(xlUp).Row) est beaucoup mieux qu'un nom de liste, car il n'y a pas de ligne vide au bas de la ListBox et l'ascenseur vertical est calibré correctement

Encore merci et bon week-end

Philippe

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
Dim f, choix()
 
Private Sub UserForm_Initialize()
 
   Set f = Sheets("Data Pieces")
      Set Rng = f.Range("H4:H" & f.[H65000].End(xlUp).Row) ' Sélectionne toutes les lignes non vide, pas de ligne vide à la fin du formulaire
 
   choix = Application.Transpose(Rng)
   Me.ListBox1.List = choix
 
     Me.TextBox1.SetFocus 'Place le curseur dans la textbox
End Sub
Private Sub TextBox1_Change()
   mots = Split(Trim(Me.TextBox1), " ") ' Permet une recherche multiple, taper les requêtes en séparant par un espace
   tbl = choix
   For i = LBound(mots) To UBound(mots)
     tbl = Filter(tbl, mots(i), True, vbTextCompare)
   Next i
   Me.ListBox1.List = tbl
End Sub
Private Sub ListBox1_Click()
  ActiveCell = Me.ListBox1 'Inscrit le texte dans la cellule active
  Unload Me
End Sub

30/10/2016, 16h25
goninph

Bonjour,

Dans la colonne H je rassemble via une formule 4 autre colonne séparée par " - ".

Comment faire la même chose en VBA dans le code du message précédent ?

Merci et bon dimanche

Philippe

1 pièce(s) jointe(s)

Bonsoir,

Dans l'exemple joint, les items sont séparés par le caractère *

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
 
Dim f, choix()
Private Sub UserForm_Initialize()
   Set f = Sheets("bd")
   Set Rng = f.Range("a2:a" & f.[A65000].End(xlUp).Row)
   TblTmp = Application.Transpose(Rng)
   p = 0
   For Each c In TblTmp
      b = Split(c, "*")
      For i = LBound(b) To UBound(b)
        p = p + 1: ReDim Preserve choix(1 To p)
        choix(p) = Trim(b(i))
      Next i
   Next c
   Me.ListBox1.List = choix
End Sub
 
Private Sub TextBox1_Change()
   mots = Split(Trim(Me.TextBox1), " ")
   Tbl = choix
   For i = LBound(mots) To UBound(mots)
     Tbl = Filter(Tbl, mots(i), True, vbTextCompare)
   Next i
   Me.ListBox1.List = Tbl
End Sub
 
Private Sub ListBox1_Click()
  Set Rng = f.Range("a2:a" & f.[A65000].End(xlUp).Row)
  Set result = Rng.Find(what:=Me.ListBox1, LookAt:=xlPart)
  If Not result Is Nothing Then
    Me.TextBox2 = result.Offset(, 1)
  End If
End Sub
 
Private Sub B_ok_Click()
  ActiveCell = Me.ListBox1
  ActiveCell.Offset(, 1) = Me.TextBox2
  Unload Me
End Sub

Boisgontier

30/10/2016, 21h13
goninph

Bonjour,

Merci pour la réponse, mais je me suis mal exprimé, en fait j'aimerai remplir la ListBox avec le contenu de 3 colonnes A + B + C séparé par -. et pouvoir coller le résultat dans une seule cellule.

Par exemple en A1 Bonjour B1 Monsieur C1 Dupond, la ListBox affiche : Bonjour - Monsieur - Dupond, et ainsi e suite pour les autres lignes

Merci et bonne soirée

Philippe
30/10/2016, 21h35
unparia

Plus rien (mais alors plus rien du tout) à voir avec la demande, telle qu'exprimée par le tout premier message.
Question pour le coup justifiée : qu'est-ce qui nous garantit que cette "précision" (... euh ...) "nouvelle", est cette-fois-ci la "bonne" ?
30/10/2016, 21h42
joe.levrai

Pourquoi ne pas rester sur l'idée de départ : une colonne dans Excel gère la concaténation des éléments, et tu injectes cette colonne dans le tableau, qui est lui même injecté dans ListBox

Citation:

Dans la colonne H je rassemble via une formule 4 autre colonne séparée par " - ".
Comment faire la même chose en VBA dans le code du message précédent ?
31/10/2016, 00h00
goninph

C'est ce que j'ai fait avec une formule dans cellules de la colonne A, par exemple : dans la cellule A1 (≠B1&" - " & C1&" - “ & D1, le problème c'est que les colonnes B, C, D, sont importées depuis SAP, et le nombre de lignes peut varier et je peux me retrouver avec 300 lignes importées et 250 lignes avec la formule. Si je rempli 1000 cellules avec la formule il y aura 700 lignes vides dans la ListBox.
Comment faire pour avoir la formule dans chaque cellules A ayant du texte en cellules B ?
Bonne nuit

Philippe

tu peux écrire dynamiquement par VBA les formules sur la plage utile de ta feuille et ensuite récupérer les résultats
ou le faire complètement en interne

un exemple paramétrable, à adapter

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Dim Tabl(), Tableau(), LaFeuille As Worksheet
Const DEBUT_LIGNE As Long = 2
Const DEBUT_COLONNE As Long = 1
Const NB_COLONNES As Long = 3
Const SEPARATEUR As String = " | "
 
Set LaFeuille = Feuil2 ' feuille à adapter
Tabl = LaFeuille.Cells(DEBUT_LIGNE, DEBUT_COLONNE).Resize(LaFeuille.Cells(LaFeuille.Rows.Count, DEBUT_COLONNE).End(xlUp).Row - DEBUT_LIGNE + 1, NB_COLONNES).Value
ReDim Tableau(UBound(Tabl, 1))
For i = LBound(Tabl, 1) To UBound(Tabl, 1)
    Tableau(i) = Join(Application.Index(Tabl, i, 0), SEPARATEUR)
Next i
Me.ListBox1.List = Tableau

1 pièce(s) jointe(s)

Bonjour,

La colonne H est la concaténation des colonnes A,B,C

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
 
Dim f, choix(), rng
Private Sub UserForm_Initialize()
   Set f = Sheets("bd")
   Set rng = f.Range("h2:h" & f.[h65000].End(xlUp).Row)
   choix = Application.Transpose(rng)
   Me.ListBox1.List = choix
End Sub
 
Private Sub TextBox1_Change()
   mots = Split(Trim(Me.TextBox1), " ")
   Tbl = choix
   For i = LBound(mots) To UBound(mots)
     Tbl = Filter(Tbl, mots(i), True, vbTextCompare)
   Next i
   Me.ListBox1.List = Tbl
End Sub
 
Private Sub ListBox1_Click()
  Set result = rng.Find(what:=Me.ListBox1, LookIn:=xlValues, LookAt:=xlWhole)
  If Not result Is Nothing Then
    Me.TextBox2 = result.Offset(, 1)
  End If
End Sub
 
Private Sub B_ok_Click()
  ActiveCell = Me.ListBox1
  ActiveCell.Offset(, 1) = Me.TextBox2
  Unload Me
End Sub

Boisgontier

31/10/2016, 15h13
goninph

Bonjour,

Merci, mais j'ai déjà concaténer la colonne A dans mon fichier, mais il y a un problème les colonnes B, C, D, sont importées depuis SAP, et le nombre de lignes peut varier.

Je peux me retrouver avec 300 lignes importées et 250 cellules concaténées, il va me manquer les 50 dernières lignes, et à l'inverse, si je concatène 1000 cellules, il y aura 700 lignes vides à la fin de la ListBox, car la ListBox reconnaît la formule comme une cellule pleine

Serai ce possible, de concaténer via VBA toutes les cellules ayant une cellule pleine à sa droite, par exemple ?

Bonne journée

Philippe

Voir 40 message(s) de cette discussion en une page