Recherche intuitive par plusieurs mots dans le désordre

C60a

XLDnaute Junior
Bonjour à tous,

Le fichier joint est tiré du code Boisgontier, que je le remercie.

L'exemple fonctionne pour une recherche intuitive par plusieurs mots dans l'ordre (Ex : "tube marron").

Mais ne l'ai pas une fois les mots recherchés sont saisis dans le désordre (Ex : "marron tube") pourtant il y a bien la ligne "Chaise tube chromé et skaï marron".

Existe-il une solution ?

Merci.
 

Fichiers joints

Dernière édition par un modérateur:

job75

XLDnaute Barbatruc
Re : Recherche intuitive par plusieurs mots dans le désordre

Bonjour C60a, JB,

Ici seuls les 2 premiers mots sont recherchés :

Code:
Private Sub ChoixArticle_Change()
Dim s, ub%, a
s = Split(ChoixArticle): ub = IIf(UBound(s) > 1, 1, UBound(s)) '2 premiers mots
If ub > -1 Then
  If IsError(Application.Match(s(0), choix1, 0)) Then
    a = Filter(choix1, s(0), True, vbTextCompare)
    a = Filter(a, s(ub), True, vbTextCompare)
  End If
End If
ChoixArticle.List = IIf(IsArray(a), a, choix1)
If ChoixArticle.ListIndex = -1 Then ChoixArticle.DropDown Else ChoixArticle_click
End Sub
Ci joint le fichier du post #1 modifié.

A+
 

Fichiers joints

Dernière édition:

C60a

XLDnaute Junior
Re : Recherche intuitive par plusieurs mots dans le désordre

Bonjour Boisgontier, job75,

Merci pour vos respectifs.

Pour les premiers tests, ça fonctionne.

Je vais essayé d'ajouter des tests pour plus de deux mots !
 

BOISGONTIER

XLDnaute Barbatruc
Re : Recherche intuitive par plusieurs mots dans le désordre

Bonsoir,

http://boisgontierjacques.free.fr/f..._deroulante_intuitive_multi_criteres_Form.xls

Code:
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
JB
 
Dernière édition:

job75

XLDnaute Barbatruc
Re : Recherche intuitive par plusieurs mots dans le désordre

Re,

Avec un maximum de 5 mots recherchés :

Code:
Private Sub ChoixArticle_Change()
Dim s, ub%, a
s = Split(ChoixArticle): ub = UBound(s)
If ub > -1 Then
  If IsError(Application.Match(s(0), choix1, 0)) Then
    a = Filter(choix1, s(0), True, vbTextCompare)
    If ub Then a = Filter(a, s(1), True, vbTextCompare)
    If ub > 1 Then a = Filter(a, s(2), True, vbTextCompare)
    If ub > 2 Then a = Filter(a, s(3), True, vbTextCompare)
    If ub > 3 Then a = Filter(a, s(4), True, vbTextCompare)
  End If
End If
ChoixArticle.List = IIf(IsArray(a), a, choix1)
If ChoixArticle.ListIndex = -1 Then ChoixArticle.DropDown Else ChoixArticle_click
End Sub
Fichier (2).

A+
 

Fichiers joints

job75

XLDnaute Barbatruc
Re : Recherche intuitive par plusieurs mots dans le désordre

Re,

Ceci fonctionne quel que soit le nombre de mots entrés :

Code:
Private Sub ChoixArticle_Change()
If IsNumeric(Application.Match(ChoixArticle, choix1, 0)) Then _
  ChoixArticle.List = choix1: ChoixArticle_Click: Exit Sub
Dim s, a, i%
s = Split(ChoixArticle): a = choix1
For i = 0 To UBound(s)
  a = Filter(a, s(i), True, vbTextCompare)
Next
ChoixArticle.List = a: ChoixArticle.DropDown
End Sub
Edition : par ailleurs dans ChoixArticle_Click l'instruction :

Code:
If Val(Application.Version) > 10 Then SendKeys "{f4}"
est particulièrement agaçante à partir d'Excel 2010 puisqu'elle désactive le pavé numérique :mad:

Je l'ai remplacée par Application.OnTime 1, "FocusChoixFournisseur" avec dans Module1 :

Code:
Sub FocusChoixFournisseur()
With UserForm1.ChoixFournisseur
  .SetFocus
  If .ListCount = 1 Then .ListIndex = 0 Else .DropDown
End With
End Sub
Fichier (3).

Bonne nuit.
 

Fichiers joints

Dernière édition:

C60a

XLDnaute Junior
Re : Recherche intuitive par plusieurs mots dans le désordre

Bonjour Boisgontier, job75,

Merci pour vos solutions, elles sont presque similaires :)

J'ai fait des tests et ça fonctionne très biens


par ailleurs dans ChoixArticle_Click l'instruction :

Code:
If Val(Application.Version) > 10 Then SendKeys "{f4}"
est particulièrement agaçante à partir d'Excel 2010 puisqu'elle désactive le pavé numérique :mad:
Et moi qui me demandais pourquoi à chaque fois je me retrouve avec un pavé éteint :rolleyes:
 
Dernière édition par un modérateur:

goninph

XLDnaute Nouveau
Bonjour BOISGONTIER,

Ci-dessous le code que vous m'aviez transmis il y a plusieurs année et je vous en remercie.

J'essaie d'afficher un bouton situé sur le USF lorsque le résultat de la recherche ne donne rien via le TextBox1_Change.
Pourriez-vous me donner un coup de main ?

Une autre demande, pourriez-vous déclarer les variables du code ci-dessous ?

Merci pour votre aide et meilleures salutations
Philippe



VB:
Option Explicit
Dim F, choix()
Private Sub BT_Ajouter_Contact_Click()
        If MsgBox("Inserer un nouveau Contact ?", vbYesNo + vbQuestion, "Contact") = vbYes Then
        Unload Me
            MsgBox "OUI"
            Else
            MsgBox "NON"
     End If
End Sub
Private Sub ListBox1_Click()
Dim Resultat As Variant
    Resultat = Me.ListBox1
        MsgBox Resultat
   Unload Me
End Sub
Private Sub UserForm_Initialize()
        Set F = Sheets("DATA Contacts Internes")
        Set Rng = F.Range("B3:B" & F.[B65000].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
'Masquer ou afficher le bouton Ajouter un contact si la recherche est nul
        If ListBox1 = "" Then
        BT_Ajouter_Contact.Visible = True
    Else
        BT_Ajouter_Contact.Visible = False
    End If
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub




Re : Recherche intuitive par plusieurs mots dans le désordre

Bonsoir,

http://boisgontierjacques.free.fr/f..._deroulante_intuitive_multi_criteres_Form.xls

Code:
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
JB
 

BOISGONTIER

XLDnaute Barbatruc
Bonjour,

La recherche par fournisseur est un autre problème (plusieurs articles pour un fournisseur).
Il faut une listBox.

VB:
Option Compare Text
Dim f, ligneEnreg, choix1()
Private Sub UserForm_Initialize()
    Set f = Sheets("BD")
    choix1 = Application.Transpose(f.Range("A2:A" & f.[a65000].End(xlUp).Row).Value)
    Me.ChoixArticle.List = choix1
    ligneEnreg = f.[a65000].End(xlUp).Row + 1
    Me.ChoixArticle.SetFocus
End Sub

Private Sub ChoixArticle_Change()
If Me.ChoixArticle <> "" Then
    If Me.ChoixArticle.ListIndex = -1 Then
        mots = Split(Trim(Me.ChoixArticle), " ")
        Tbl = choix1
        For Each m In mots
          Tbl = Filter(Tbl, m, True, vbTextCompare)
        Next m
        Me.ChoixArticle.List = Tbl
      Else
        ChoixArticle_click
      End If
    Else
      Me.ChoixArticle.List = choix1
    End If
    Me.ChoixArticle.DropDown
End Sub

Private Sub ChoixArticle_click()
  Set result = f.[A:A].Find(what:=Me.ChoixArticle)
  If Not result Is Nothing Then
    Me.TextBox1 = result
    For i = 2 To 3: Me("textbox" & i) = result.Offset(, i - 1): Next i
  End If
End Sub
Boisgontier
 

Fichiers joints

Dernière édition:

BOISGONTIER

XLDnaute Barbatruc
Bonjour,

VB:
Option Explicit
Dim f, choix(), Rng
Private Sub UserForm_Initialize()
  Set f = Sheets("DATA Contacts Internes")
  Set Rng = f.Range("B3:B" & f.[B65000].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 ListBox1_Click()
  Dim Resultat As Variant
  Resultat = Me.ListBox1
  MsgBox Resultat
  Unload Me
End Sub

Private Sub TextBox1_Change()
  Dim Mots, Tbl, i, temp
  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
  'Masquer ou afficher le bouton Ajouter un contact si la recherche est nul
  BT_Ajouter_Contact.Visible = (ListBox1.ListCount = 0)
End Sub

Private Sub BT_Ajouter_Contact_Click()
  If MsgBox("Inserer un nouveau Contact ?", vbYesNo + vbQuestion, "Contact") = vbYes Then
     Unload Me
     MsgBox "OUI"
  Else
     MsgBox "NON"
  End If
End Sub
Boisgontier
 

Fichiers joints

Dernière édition:

goninph

XLDnaute Nouveau
Bonjour,

VB:
Option Explicit
Dim f, choix(), Rng
Private Sub UserForm_Initialize()
  Set f = Sheets("DATA Contacts Internes")
  Set Rng = f.Range("B3:B" & f.[B65000].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 ListBox1_Click()
  Dim Resultat As Variant
  Resultat = Me.ListBox1
  MsgBox Resultat
  Unload Me
End Sub

Private Sub TextBox1_Change()
  Dim Mots, Tbl, i, temp
  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
  'Masquer ou afficher le bouton Ajouter un contact si la recherche est nul
  BT_Ajouter_Contact.Visible = (ListBox1.ListCount = 0)
End Sub

Private Sub BT_Ajouter_Contact_Click()
  If MsgBox("Inserer un nouveau Contact ?", vbYesNo + vbQuestion, "Contact") = vbYes Then
     Unload Me
     MsgBox "OUI"
  Else
     MsgBox "NON"
  End If
End Sub
Boisgontier
Merci ça fonctionne nickel
Meilleures salutations
Philippe
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas