XL 2016 Mise à jour d'une ListBox incorrecte dans un UserForm

Guy52

XLDnaute Nouveau
Bonjour,
j'utilise un code créé je crois par Mr Boisgontier.

VB:
Private Sub TextBox1_Change()
  If Me.TextBox1 <> "" Then
     mots = Split(Trim(Me.TextBox1), " ")
     Tbl = choix
     For I = LBound(mots) To UBound(mots)
        Tbl = Filter(Tbl, mots(I), True, vbTextCompare)
     Next I
     If UBound(Tbl) > -1 Then
        Dim b(): ReDim b(1 To UBound(Tbl) + 1, 1 To Ncol)
        For I = LBound(Tbl) To UBound(Tbl)
          a = Split(Tbl(I), "*")
          For K = 1 To Ncol: b(I + 1, K) = a(K - 1): Next K
        Next I
        Me.ListBox1.List = b
        Me.Label1.Caption = UBound(Tbl) + 1 & " Ligne(s)"
     End If
Mais lorsque je cherche lev dans la liste ci-dessous.

Etude géologique et métallogénique de la région de Vabre, Ferrières et Brassac (Tarn)
Etude tectonique et microtectonique comparée de deux domaines hercyniens:
Les nappes de la Montagne Noire (France) et l’Anticlinorium de l’Iglesiense (Sardaigne)
Le Quercy blanc au sud-ouest de Cahors: Aperçu paléogéographique et structural et Ressources du sol.
Le dôme «Orthogneissique» de Montredon-Labessonnié (Tarn) et son enveloppe métamorphique
Le Paléozoïque du Massif de l’Arize (Pyrénées Ariégeoises)
La zone cénomanienne à l’Est de la Vallée du Salat. Etude stratigraphique et structurale
Le volcanisme de l’Ossau (Pyrénées Atlantiques) : pétrologie et analyse structurale
Le massif granitique du Sidobre : pétrographie, structures, relation mise en place cristallisation

Voici le retour qui s'affiche.

1028769

La comparaison du texte ne fonctionne pas car il n'y a aucune thèse dont le sujet comporte ces trois lettres.

Je ne sais pas si une solution existe ?
J'espère avoir respecté la charte de ce Forum car c'est la première fois que je l'utilise.

Cordialement
Guy52
 

ChTi160

XLDnaute Barbatruc
Bonjour Guy52
Bienvenue !
je pense que sans un fichier (données non confidentielles) , tu n'auras pas beaucoup de réponse !
Bonne journée
jean marie
 

Guy52

XLDnaute Nouveau
Bonjour Jean-Marie (Chti160),
merci pour ton message d'accueil.
Voici mon fichier qui est en cours de construction.
il s'agit de faciliter la recherche dans la bibliothèque de notre association : l'ASNAT, animée par un certain nombre de bénévoles. Elle contient un certain nombre de thèses et de publications en relation avec les Sciences de la Nature notamment dans le Tarn.

Voici donc le fichier où il n'y a rien de confidentiel.
Je fais actuellement le test sur la recherche de thèses.

Bonne journée
Cordialement,
Guy
 

Fichiers joints

Jacky67

XLDnaute Accro
Bonjour à tous

*Tester ceci en debut de macro
VB:
Private Sub TextBox1_Change()
Me.ListBox1.Clear  '<===
If Me.TextBox1 <> "" Then
''-----
'------'
 

ChTi160

XLDnaute Barbatruc
Re
Bonjour jacky
je poste quand même Lol
j'avais modifié ainsi :
VB:
If UBound(Tbl) > -1 Then
        Dim b(): ReDim b(1 To UBound(Tbl) + 1, 1 To Ncol)
        For I = LBound(Tbl) To UBound(Tbl)
          a = Split(Tbl(I), "*")
          For K = 1 To Ncol: b(I + 1, K) = a(K - 1): Next K
        Next I
        Me.ListBox1.List = b
        Me.Label1.Caption = UBound(Tbl) + 1 & " Ligne(s)"
     Else 'Ici <====
        Me.ListBox1.Clear ' et là <=====
End If
jean marie
 

Jacky67

XLDnaute Accro
Re
Bonjour jacky
je poste quand même Lol
j'avais modifié ainsi :
VB:
If UBound(Tbl) > -1 Then
        Dim b(): ReDim b(1 To UBound(Tbl) + 1, 1 To Ncol)
        For I = LBound(Tbl) To UBound(Tbl)
          a = Split(Tbl(I), "*")
          For K = 1 To Ncol: b(I + 1, K) = a(K - 1): Next K
        Next I
        Me.ListBox1.List = b
        Me.Label1.Caption = UBound(Tbl) + 1 & " Ligne(s)"
     Else 'Ici <====
        Me.ListBox1.Clear ' et là <=====
End If
jean marie
Bonjour à tous,

Jean -Marie
Oui c'est beaucoup plus mieux :)
Ca m'apprendra à ne pas lire en diagonale :cool:

**En plus c'est confirmé par Maitre Boisgontier
 
Dernière édition:

BOISGONTIER

XLDnaute Barbatruc
Version avec choix des colonnes à interroger.

VB:
Dim f, choix(), Rng, BD(), Ncol, ColVisu()
Private Sub UserForm_Initialize()
   Set f = Sheets("THESES")
   ColVisu = Array(1, 2, 3, 4, 5, 6)       ' colonnes à visualiser
   colInterro = Array(1, 2, 3, 4, 5)       ' colonnes à interroger
   Set Rng = f.Range("A2:F" & f.[a65000].End(xlUp).Row)
   BD = Rng.Value
   Ncol = UBound(ColVisu) + 1
   '-- en têtes de colonne ListBox
   x = Me.ListBox1.Left + 8
   Y = Me.ListBox1.Top - 12
   For Each k In ColVisu
     Set Lab = Me.Controls.Add("Forms.Label.1")
     Lab.Caption = f.Cells(1, k)
     Lab.Top = Y
     Lab.Left = x
     x = x + f.Columns(k).Width * 0.9
     temp = temp & f.Columns(k).Width * 0.9 & ";"
   Next
   temp = Left(temp, Len(temp) - 1)
   Me.ListBox1.ColumnCount = UBound(ColVisu) + 1
   Me.ListBox1.ColumnWidths = temp
   '---
   ReDim choix(1 To UBound(BD))
   For i = LBound(BD) To UBound(BD)
     For Each k In colInterro
       choix(i) = choix(i) & BD(i, k) & "|"
     Next k
   Next i
   '--- valeurs initiales dans ListBox
   Dim Tbl(): ReDim Tbl(1 To UBound(BD), 1 To Ncol)
   For i = 1 To UBound(BD)
      C = 0
      For Each k In ColVisu
        C = C + 1: Tbl(i, C) = BD(i, k)
      Next k
   Next i
   'TriMultiCol Tbl, LBound(Tbl), UBound(Tbl), 1
   Me.ListBox1.List = Tbl
   Me.Label1.Caption = Me.ListBox1.ListCount & " Ligne(s)"
End Sub

Private Sub TextBox1_Change()
  If Me.TextBox1 <> "" Then
     mots = Split(Trim(Me.TextBox1), " ")
     Tbl = choix
     For i = LBound(mots) To UBound(mots)
        Tbl = Filter(Tbl, mots(i), True, vbTextCompare)
     Next i
     If UBound(Tbl) > -1 Then
        Dim b(): ReDim b(1 To UBound(Tbl) + 1, 1 To Ncol)
        For i = LBound(Tbl) To UBound(Tbl)
          a = Split(Tbl(i), "|")
          For k = 1 To Ncol: b(i + 1, k) = a(k - 1): Next k
        Next i
        Me.ListBox1.List = b
        Me.Label1.Caption = UBound(Tbl) + 1 & " Ligne(s)"
     Else
        Me.ListBox1.Clear
     End If
  Else
     UserForm_Initialize
  End If
End Sub
Boisgontier
 

Fichiers joints

Guy52

XLDnaute Nouveau
Version avec choix des colonnes à interroger.

VB:
Dim f, choix(), Rng, BD(), Ncol, ColVisu()
Private Sub UserForm_Initialize()
   Set f = Sheets("THESES")
   ColVisu = Array(1, 2, 3, 4, 5, 6)       ' colonnes à visualiser
   colInterro = Array(1, 2, 3, 4, 5)       ' colonnes à interroger
   Set Rng = f.Range("A2:F" & f.[a65000].End(xlUp).Row)
   BD = Rng.Value
   Ncol = UBound(ColVisu) + 1
   '-- en têtes de colonne ListBox
   x = Me.ListBox1.Left + 8
   Y = Me.ListBox1.Top - 12
   For Each k In ColVisu
     Set Lab = Me.Controls.Add("Forms.Label.1")
     Lab.Caption = f.Cells(1, k)
     Lab.Top = Y
     Lab.Left = x
     x = x + f.Columns(k).Width * 0.9
     temp = temp & f.Columns(k).Width * 0.9 & ";"
   Next
   temp = Left(temp, Len(temp) - 1)
   Me.ListBox1.ColumnCount = UBound(ColVisu) + 1
   Me.ListBox1.ColumnWidths = temp
   '---
   ReDim choix(1 To UBound(BD))
   For i = LBound(BD) To UBound(BD)
     For Each k In colInterro
       choix(i) = choix(i) & BD(i, k) & "|"
     Next k
   Next i
   '--- valeurs initiales dans ListBox
   Dim Tbl(): ReDim Tbl(1 To UBound(BD), 1 To Ncol)
   For i = 1 To UBound(BD)
      C = 0
      For Each k In ColVisu
        C = C + 1: Tbl(i, C) = BD(i, k)
      Next k
   Next i
   'TriMultiCol Tbl, LBound(Tbl), UBound(Tbl), 1
   Me.ListBox1.List = Tbl
   Me.Label1.Caption = Me.ListBox1.ListCount & " Ligne(s)"
End Sub

Private Sub TextBox1_Change()
  If Me.TextBox1 <> "" Then
     mots = Split(Trim(Me.TextBox1), " ")
     Tbl = choix
     For i = LBound(mots) To UBound(mots)
        Tbl = Filter(Tbl, mots(i), True, vbTextCompare)
     Next i
     If UBound(Tbl) > -1 Then
        Dim b(): ReDim b(1 To UBound(Tbl) + 1, 1 To Ncol)
        For i = LBound(Tbl) To UBound(Tbl)
          a = Split(Tbl(i), "|")
          For k = 1 To Ncol: b(i + 1, k) = a(k - 1): Next k
        Next i
        Me.ListBox1.List = b
        Me.Label1.Caption = UBound(Tbl) + 1 & " Ligne(s)"
     Else
        Me.ListBox1.Clear
     End If
  Else
     UserForm_Initialize
  End If
End Sub
Boisgontier
 

Guy52

XLDnaute Nouveau
Rebonjour,

merci à vous tous pour vos compétences, la rapidité de vos réponses et votre dévouement.

Grâce à vous tout marche nickel

Cordialement
Guy
 
Haut Bas