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.
 

Pièces jointes

  • Recherche_inituitive_v001.xlsm
    25.2 KB · Affichages: 44
Dernière modification par un modérateur:

BOISGONTIER

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

Bonjour,

Exemple

-avec 2 mots seulement dans le désordre
-avec plusieurs mots dans l'ordre

JB
 

Pièces jointes

  • Liste_deroulante_intuitive_multi_criteresV2-2.zip
    220.2 KB · Affichages: 53
Dernière édition:

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+
 

Pièces jointes

  • Recherche_inituitive(1).xlsm
    31.9 KB · Affichages: 38
Dernière édition:

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
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+
 

Pièces jointes

  • Recherche_inituitive(2).xlsm
    32 KB · Affichages: 36

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.
 

Pièces jointes

  • Recherche_inituitive(3).xlsm
    34.1 KB · Affichages: 53
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 modification 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
Repose en paix
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
 

Pièces jointes

  • Copie de Recherche_inituitive_v001.xlsm
    29.1 KB · Affichages: 5
Dernière édition:

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
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
 

Pièces jointes

  • Classeur1.xlsm
    51.7 KB · Affichages: 7
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
 

Discussions similaires

Réponses
16
Affichages
981

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof