double saisie intuitive

bernardrustrel

XLDnaute Occasionnel
Bonjour
le fichier joint présente sur la Textbox1 une saisie intuitive d'un nom d'acteur. Or j'aimerais pouvoir, si cela est possible , dans la même Textbox1 saisir de la même façon un deuxième acteur.
Je détaille, après la premier acteur je positionne une "," et un espace la Textbox1 se présente alors ainsi
"Alain Chabat, "espace""
C'est la que ça se complique , car il faudrait que la Listbox1 me permette de choisir un deuxième acteur issu de la liste initiale.
Ce devrai donner une fois ce dernier choisi:"Alain Chabat, Marion Cotillard"
J'avoue me mélanger sacrement les pinceaux dans la chronologie de sollicitation de la Listbox1.
Aussi l'un vous saurait il venir à mon aide, je l'en remercie déjà grandement
Cordialement,Bernard
 

Pièces jointes

  • testacteur.xlsm
    17.9 KB · Affichages: 34

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Bonjour,

Code:
Option Compare Text
Dim f, Choix(), d1, d2
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
   Set d1 = CreateObject("scripting.dictionary")
   Set d2 = CreateObject("scripting.dictionary")
End Sub

Private Sub TextBox1_Change()
   d1.RemoveAll
   For i = 1 To UBound(Choix)
     If Choix(i) Like Me.TextBox1 & "*" Then d1(Choix(i)) = ""
   Next i
   Me.ListBox1.List = Fusion
End Sub

Private Sub TextBox2_Change()
   d2.RemoveAll
   For i = 1 To UBound(Choix)
     If Choix(i) Like Me.TextBox2 & "*" Then d2(Choix(i)) = ""
   Next i
   Me.ListBox1.List = Fusion
End Sub

Function Fusion()
Set d3 = CreateObject("Scripting.Dictionary")
For Each c In d1.keys: d3(c) = "": Next c
For Each c In d2.keys: d3(c) = "": Next c
Fusion = d3.keys
End Function

jb
 

Pièces jointes

  • RechercheIntuitiveOU.xls
    63 KB · Affichages: 23
  • RechercheIntuitiveMultiMotsOU.xls
    145 KB · Affichages: 22
Dernière édition:

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Plusieurs recherches avec un seul TextBox

Code:
Option Compare Text
Dim f, Choix(), d1
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()
   Set d1 = CreateObject("scripting.dictionary")
   mots = Split(Trim(Me.TextBox1), ",")
   For Each m In mots
     mots2 = Split(Trim(m), " ")
     Tbl = Choix
     For i = LBound(mots2) To UBound(mots2)
       Tbl = Filter(Tbl, mots2(i), True, vbTextCompare)
     Next i
     For i = LBound(Tbl) To UBound(Tbl): d1(Tbl(i)) = "": Next i
   Next m
   Me.ListBox1.List = d1.keys
End Sub

http://boisgontierjacques.free.fr/fichiers/Formulaire/RechercheIntuitiveMultiMotsOU.xls

jb
 

Pièces jointes

  • RechercheIntuitiveMultiMotsOU3.xls
    72 KB · Affichages: 24
  • RechercheIntuitiveMultiMotsOU2.xls
    135 KB · Affichages: 22
  • Sans titre.png
    Sans titre.png
    4.9 KB · Affichages: 35
Dernière édition:

bernardrustrel

XLDnaute Occasionnel
Bonsoir
Merci pour votre promptitude quant à répondre à ma demande.
J'avoue avoir omis un détail, en effet j'ai ajouté:
Private Sub ListBox1_Click()
TextBox1 = Me.ListBox1
End Sub
Ce qui me permet de valider mon premier choix. Ensuite afin de passer au second acteur je n'arrive pas à ce que le premier reste dans la textbox1 .
Je décris pas à pas
1/ saisie des premiers caractères du 1er acteur (ce qui donne: Al)
2/validation du 1er acteur par click dans listbox1 (ce qui donne: Al Pacino)
3/saisie virgule et espace dans textbox1 (ce qui donne: Al Pacino, )
4/saisie des premiers caractères du 2eme acteur (ce qui donne: Al Pacino, Cl)
5/validation du 2eme acteur par click dans listbox1 (ce qui donne: Al Pacino, Clint Esatwood)
le plus dur pour moi est que le passage du 4 au 5

Merci encore à vous.
Bernard
 

bernardrustrel

XLDnaute Occasionnel
Bonjour JB
J'ai adapte le fichier joint à mon besoin, cela a l'air de fonctionner jusqu'à (pour l'avoir tester) 3 acteurs.
Je ne pense pas que ces quelques lignes rajoutées soient des plus élégantes mais en attendant de faire mieux.
Merci encore grandement
Bernard
 

Pièces jointes

  • RechercheIntuitiveMultiMotsOU31.xls
    77.5 KB · Affichages: 12

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Bonjour,

>cela a l'air de fonctionner jusqu'à (pour l'avoir tester) 3 acteurs

Essai avec 6 acteurs en PJ (sans modification)

jb
 

Pièces jointes

  • Copie de RechercheIntuitiveMultiMotsOU3-3.xls
    74 KB · Affichages: 23
  • Sans titre.png
    Sans titre.png
    12.8 KB · Affichages: 27

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 019
Membres
101 872
dernier inscrit
Colin T