Microsoft 365 Userform : Combobox triée/sans doublons avec saisie intuitive/recherche multimots

lusert

XLDnaute Junior
Bonjour à tous,

Ce post sera le dernier, je l'espère concernant le développement d'un formulaire de saisie de noms d'espèce pour faciliter la vie des naturalistes et rester à jours avec les normes d'écritures ICBN (mise en forme des noms d'espèces et d'auteurs) et INPN (versions TAXREF).

Mon code actuel me permet d'agir sur la mise en forme du texte (italique, balise et couleur) et de faire une saisie intuitive par recherche multimots (exemple j'écris "ab al" ou "ab al pour faire apparaitre tous les noms d'espèces comportant ces lettres comme "Abies alba susp alba nom d'auteur" J'ai intégré un code qui trie et sans doublons et depuis impossible d'utiliser la saisie intuitive par recherche mutlimots.
Code proposé par M.Boisgontier (ci-dessous) pour la saisie intuitive type Ab Al pour Abies alba :
VB:
Dim choix1()
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([B77:B124], Target) Is Nothing And Target.Count = 1 Then
    choix1 = Application.Transpose(Sheets("bd").Range("liste").Value)
    Me.ComboBox1.List = choix1
    Me.ComboBox1.Height = Target.Height + 3
    Me.ComboBox1.Width = Target.Width
    Me.ComboBox1.Top = Target.Top
    Me.ComboBox1.Left = Target.Left
    Me.ComboBox1 = Target
    Me.ComboBox1.Visible = True
    Me.ComboBox1.Activate
  Else
    Me.ComboBox1.Visible = False
  End If
End Sub

Private Sub ComboBox1_Change()
If Me.ComboBox1 <> "" Then
     mots = Split(Trim(Me.ComboBox1), " ")
     Tbl = choix1
     For i = LBound(mots) To UBound(mots)
       Tbl = Filter(Tbl, mots(i), True, vbTextCompare)
     Next i
     Me.ComboBox1.List = Tbl
     Me.ComboBox1.DropDown
End If
End Sub

Private Sub ComboBox1_click()
  ActiveCell = Me.ComboBox1
End Sub

Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  If KeyCode = 13 Then
    ActiveCell.Offset(1).Select
  End If
End Sub

Code permettant de trier et avoir une liste sans doublon

Code:
Private Sub UserForm_Initialize()
  Me.ComboBox1.Clear
 
   Set f = Sheets("BD")
  Set MonDico = CreateObject("Scripting.Dictionary")
  a = f.Range("z3:z" & f.[z65000].End(xlUp).Row)   ' tableau a(n,1) pour rapidité
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then MonDico(a(i, 1)) = ""
  Next i
  '--avec tri
  temp = MonDico.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
 End Sub

Sub Tri(a, gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2) ' l'antislah \ donne la partie entière d'une division
  g = gauc: d = droi
  Do
     Do While a(g) < ref: g = g + 1: Loop
     Do While ref < a(d): d = d - 1: Loop
     If g <= d Then
        temp = a(g): a(g) = a(d): a(d) = temp
        g = g + 1: d = d - 1
     End If
   Loop While g <= d
   If g < droi Then Call Tri(a, g, droi)
   If gauc < d Then Call Tri(a, gauc, d)
End Sub

Mon formulaire comporte une combobox1 qui selon l'espèce saisie va afficher des correspondances dans différents texbox (voir fichier version saisie avec...). Quand j'intègre les codes de tries et sans doublons (fichier version sans saisie) ça ne fonctionne plus, je suis obligé d'enlever les codes de saisie intuitive et les codes liés permettant d'afficher une valeur dans les textbox.

Je vois que le problème et au niveau de la plage de données de la liste de la combobox1 et des codes utilisés basés sur a et temp ou choix1. Je n'arrive pas à adapter tous cela.

Si vous avez des idées sur le pourquoi du comment je vous en remercie d'avance. J'ai fait un certain nombre de manipulations et tests sans résultats...
 

Pièces jointes

  • version sans saisie intuitive avec trie et sans doublons.xlsm
    539.3 KB · Affichages: 29
  • version saisie avec saisie intuitive sans trie et avec doublon.xlsm
    587.8 KB · Affichages: 24

AtTheOne

XLDnaute Accro
Supporter XLD
Bonjour à tous, bonjour @lusert

Avec quelques modifications.
J'ai mis dans les items du dictionnaire les informations utilisées par les macros (séparée par le caractère "¤")
Puis j'utilise la clef choisie par la ComboBox pour ramener ces informations.

(Moi, je ne laisse pas les noms par défaut des objets de userform, mais bon ...;))

UserForm_Initialize :
Enrichi (BBcode):
Dim choix1()
Dim MonDico As Object  'ou As Scripting.Dictionary 'Si  Microsoft Scripting Runtime en référence


Private Sub UserForm_Initialize()
     Me.ComboBox1.Clear
     
     Set F = Sheets("BD")
     Set MonDico = CreateObject("Scripting.Dictionary")
'     Set MonDico = New Scripting.Dictionary   'Si Microsoft Scripting Runtime en référence
     DerCell = F.Cells(F.Rows.Count, 26).End(xlUp).Row
     a = F.Range("z2:z" & DerCell)  ' tableau a(n,1) pour rapidité
     CD_Nom = F.Range("A2:A" & DerCell)
     Url = F.Range("T2:T" & DerCell)
     ZH = F.Range("AG2:AG" & DerCell)
     
     For i = LBound(a) To UBound(a)
          If a(i, 1) <> "" Then MonDico(a(i, 1)) = CD_Nom(i, 1) & "¤" & Url(i, 1) & "¤" & ZH(i, 1)
     Next i
     '--avec tri
     choix1 = MonDico.keys
     Call Tri(choix1, LBound(choix1), UBound(choix1))
     Me.ComboBox1.List = choix1
     Me.ComboBox1.SetFocus
     
 End Sub

ComboBox1_Change
Enrichi (BBcode):
Private Sub ComboBox1_Change()
     Dim Ind As Long, n As Long, Tt()
     If Me.ComboBox1.ListIndex = -1 And IsError(Application.Match(Me.ComboBox1, choix1, 0)) Then
          Me.ComboBox1.List = Filter(choix1, Me.ComboBox1.Text, True, vbTextCompare)
          If Me.ComboBox1 <> "" Then
               mots = Split(Trim(Me.ComboBox1), " ")     ' divise puis réduit la combobox
               Tbl = choix1
               For i = LBound(mots) To UBound(mots)
                    Tbl = Filter(Tbl, mots(i), True, vbTextCompare)
               Next i
               Me.ComboBox1.List = Tbl
               Me.ComboBox1.DropDown
          End If
          Me.TextBox1 = ""
          Me.TextBox2 = ""
          Me.TextBox3 = ""
     Else
          P = Split(MonDico(Me.ComboBox1.Text), "¤")
          Me.TextBox1 = P(0)  'CD_Nom
          Me.TextBox2 = P(1)  'lb_nom_URL
          Me.TextBox3 = P(2)  'ZH
     End If
End Sub

CommandButton1_Click
Enrichi (BBcode):
Private Sub CommandButton1_Click()
 
     ActiveCell.Offset(, 1) = ComboBox1
     ActiveCell.Offset(, 2) = Me.TextBox1
     If Me.TextBox3 = "1" Then ActiveCell.Offset(, 3) = "ZH"

... suite du code inchangée

   End Sub

Voir le fichier en PJ
Amicalement
Alain
 

Pièces jointes

  • Version B.xlsm
    535.6 KB · Affichages: 38

lusert

XLDnaute Junior

Merci à toi AtTheOne,​

Je viens de tester ton modèle ! C'est super ça correspond à ce que j'essayais de construire.
Cette macro pourra aider un grand nombre de naturalistes, merci à toi :)

De mon côté (il y a 15 jours de ça maintenant) j'ai pu améliorer le fichier d'origine et rejoindre un rendu similaire. Ce serait avec plaisir que tu me donnes ton avis sur le code que j'ai produit pour cette histoire de combobox, triée sans doublons.
 

Dranreb

XLDnaute Barbatruc
Bonsoir.
Information.
Au cas où ça vous intéresse, je propose très souvent ici de la programmation de service dont un module standard avec pour principal dispositif une fonction renvoyant non seulement une liste classée sans doublon d'infos prises d'une colonne, mais aussi les listes de numéros des lignes où elles s'y trouvent. Ça évite d'avoir à les rechercher à postériori dans la base suite à un choix dans une ComboBox à laquelle cette liste à été attribuée.
 

AtTheOne

XLDnaute Accro
Supporter XLD
Bonjour @Dranreb

Excuse-moi, j'étais occupé sur un autre fil, j'avais déjà vu ton outil (à propos de menus de cantine) mais je n'ai pas trouvé le temps de me l'approprier.
Excuse-moi de nouveau mais je préfère bien comprendre avant de l'utiliser. Je regarde ton exemple et je reviens vers toi (il faut dire que le code est dense o_O et que les commentaires ne sont pas légion ;))

Amicalement
Alain
 

Dranreb

XLDnaute Barbatruc
Il y a une page d'aide ici dont une rubrique consacrée au module MSujetCBx
 

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
315 087
Messages
2 116 084
Membres
112 655
dernier inscrit
fannycordi