Recherche et création ListBox de plus de 10 colonnes

Version imprimable

1 pièce(s) jointe(s)

Bonjour à tous,

Etant débutant en VBA Excel, je développe une petite application de test qui réalise des recherches, insertions et modifications de tableaux en feuille Excel via des formulaires.

Je rencontre un problème au niveau de la recherche, pour afficher dans une ListBox le résultat de ma recherche.
En effet, cela fonctionne correctement jusqu'à 10 champs, mais tombe en erreur si je souhaite récupérer + de champs.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Me.List_Search.Clear Set c = Sheets("BDD").Range("a:a").Find(Me.TB_Nom.Value, LookIn:=xlValues) If Not c Is Nothing Then premier = c.Address i = 0 Do Me.List_Search.AddItem Me.List_Search.List(i, 0) = c.Value Me.List_Search.List(i, 1) = c.Offset(0, 1).Value Me.List_Search.List(i, 2) = c.Offset(0, 2).Value Me.List_Search.List(i, 3) = c.Offset(0, 4).Value Me.List_Search.List(i, 4) = c.Offset(0, 5).Value Me.List_Search.List(i, 5) = c.Offset(0, 6).Value Me.List_Search.List(i, 6) = c.Offset(0, 7).Value Me.List_Search.List(i, 7) = c.Offset(0, 8).Value Me.List_Search.List(i, 8) = c.Offset(0, 9).Value Me.List_Search.List(i, 9) = c.Offset(0, 10).Value Me.List_Search.List(i, 10) = c.Offset(0, 11).Value Set c = Sheets("BDD").Range("a:a").FindNext(c) i = i + 1 Loop While Not c Is Nothing And c.Address <> premier End If
De plus, je souhaiterai pouvoir récupérer tous les champs de mon tableau mais n'en afficher que certains dans la listBox.
Par contre, il me faut bien l'information, car sur un double-click, je voudrai afficher toutes les informations dans un nouveau UserForm.

Jusqu'à 10 champs, mon code fonctionne jusqu'au bout, mais au-delà plus rien ne marche.

Après différentes recherches sur Internet/Forums, j'ai l'impression qu'il faudrait renseigner un tableau et ne plus utiliser cette façon de faire: Me.List_Search.List(i, 10) = c.Offset(0, 11).Value
Mais je ne trouve pas de façon de faire qui réalise à la fois la recherche comme je souhaite, et le remplissage de ma ListBox.

Je vous mets en pièce jointe mon fichier de test.

Merci d'avance pour vos réponses, indices ou quoi que ce soit qui me mette sur la bonne voie !

07/08/2015, 13h46
Docmarti

Bonjour.

La méthode AddItem est limitée à 10 colonnes.

Il faut donc utiliser l'Alimentation par List.

Voir sur le site de Jacques Boisgontier Alimentation par List

EDIT: et sa mise en garde S'il n'y a qu'une ligne dans Tbl()

EDIT: Bonjour Thauthème

Bonjour Chris, bonjour le forum,

La méthode AddItem ne tolère que 10 colonnes au maximum ! Il te faut donc passer par une autre méthode. Le code ci-dessous utilise une tableau TL qui rajoute les éléments et, à la fin, alimente la listbox par transposition :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Dim R As Range 'déclare la variable R (Recherche)
Dim TL() As Variant 'declare le tableau de lignes TL
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim PA As String 'déclare la variable PA (Première Adresse)
 
Me.List_Search.Clear 'efface le contenu de la listbox "List_Search"
Set R = Sheets("BDD").Range("A:A").Find(Me.TB_Nom.Value, LookIn:=xlValues) 'définit la recherche R
If Not R Is Nothing Then 'condition : si il existe au moin sune occurrence trouvée
    PA = R.Address 'définit l'adresse de la première occurrence trouvée
    I = 1 'initialise la variable I
    Do 'éxécute
        ReDim Preserve TL(10, 1 To I) 'redimensionne le tableau de lignes TL (11 lignes de 0 à 10, K colonnes)
        For J = 0 To 10 'boucles sur les 10 lignes de tableau de lignees TL
            TL(J, I) = R.Offset(0, J).Value 'récupère la valeur de l'occurrence trouvée décalée de J colonnes à droite
        Next J 'prochaine ligne de la boucle
        I = I + 1 'incrémente I (ajoute une colonne au tableau de lignes TL)
        Set R = Sheets("BDD").Range("a:a").FindNext(R) 'redéfinit la recherche R (occurrence suivante)
    Loop While Not R Is Nothing And R.Address <> PA 'boucle tant qu'il existe de nouvelles occurrences ailleurs qu'en PA
End If 'fin de la condition
If K > 1 Then 'condition : si K est supérieur à 1 (au moins une occurrence a été trouvée)
    'si K=2 (une seule occurrence trouvée), redimensionne le tableau TL pour permettre la tranposition (sinon plantage)
    If K = 2 Then ReDim Preserve TL(UBound(TL), 1 To 2)
    Me.List_Search.List = Application.Transpose(TL) 'alimente la listbox "List_Search" avec le tableau TL transposé
End If

[Édition]
Bonjour Docmarti, nous nous sommes croisé...

Bonjour,

Merci pour ce retour.
J'avais effectivement trouvé cette page, mais j'avais rencontré des problèmes de librairie "Projet ou bibliothèque introuvable" qui m'ont empêché de tester ce Scripting.dictionary.
J'ai pourtant bien activé les références : Microsoft Scripting Runtim et Miscrosoft Scriptlet Library (informations trouvées sur le net)

De plus, si je comprends bien ce code, il permet d'afficher toutes les colonnes de mon tableau sélectionné: je n'ai pas trouvé pas comment définir des colonnes visibles et d'autres non visibles.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Private Sub ComboBox1_Click() Dim a() n = Application.CountIf(Application.Index(bd, , 1), Me.ComboBox1) ReDim a(1 To n, 1 To bd.Columns.Count) ligne = 0 For i = 1 To bd.Rows.Count If bd.Cells(i, 1) = Me.ComboBox1 Then ligne = ligne + 1 For k = 1 To bd.Columns.Count: a(ligne, k) = bd.Cells(i, k): Next k End If Next i Me.ListBox1.List = a() End Sub
Je continue de chercher des informations sur l'alimentation par List.

Bonjour Thautheme,

Désolé je n'avais pas vu votre message.
J'ai remplacé les K par des R en fin de code et essayé sur mon application.
Cela affiche bien les valeurs du tableau quand la recherche récupère plusieurs lignes, par contre s'il n'y a qu'1 ligne de trouvée, tout s'affiche sur la 1ère colonne de la ListBox.
Je continue mon analyse de votre code, mais est-il possible en se basant sur ce principe, de n'afficher que certaines colonnes dans la ListBox tout en gardant les valeurs masquées pour les utiliser ensuite sur clic ?

Merci en tout cas pour ce retour, je comprends mieux comment fonctionne ce type d'alimentation.

EDIT : En fait, il ne fallait pas remplacer K par R mais définir K et ajouter une incrémentation à chaque occurrence trouvée.
Le code ci-dessous affiche bien les lignes entières qu'il n'y en ai qu'1 ou plusieurs.
Si j'ai bien compris, le max est 10 lignes dans ce code ?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
  Dim R As Range 'déclare la variable R (Recherche)
Dim TL() As Variant 'declare le tableau de lignes TL
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Byte 'déclare la variable K (incrément)
Dim PA As String 'déclare la variable PA (Première Adresse)
 
Me.List_Search.Clear 'efface le contenu de la listbox "List_Search"
Set R = Sheets("BDD").Range("A:A").Find(Me.TB_Nom.Value, LookIn:=xlValues) 'définit la recherche R
If Not R Is Nothing Then 'condition : si il existe au moin sune occurrence trouvée
    PA = R.Address 'définit l'adresse de la première occurrence trouvée
    I = 1 'initialise la variable I
    Do 'éxécute
        ReDim Preserve TL(10, 1 To I) 'redimensionne le tableau de lignes TL (11 lignes de 0 à 10, K colonnes)
        For J = 0 To 10 'boucles sur les 10 lignes de tableau de lignees TL
            TL(J, I) = R.Offset(0, J).Value 'récupère la valeur de l'occurrence trouvée décalée de J colonnes à droite
        Next J 'prochaine ligne de la boucle
        I = I + 1 'incrémente I (ajoute une colonne au tableau de lignes TL)
        K = K + 1 'incremente le nombre d'occurences trouvées
        Set R = Sheets("BDD").Range("a:a").FindNext(R) 'redéfinit la recherche R (occurrence suivante)
    Loop While Not R Is Nothing And R.Address <> PA 'boucle tant qu'il existe de nouvelles occurrences ailleurs qu'en PA
End If 'fin de la condition
If K > 0 Then 'condition : si K est supérieur à 0 (au moins une occurrence a été trouvée)
    'si K=2 (une seule occurrence trouvée), redimensionne le tableau TL pour permettre la tranposition (sinon plantage)
    If K = 1 Then ReDim Preserve TL(UBound(TL), 1 To 2)
    Me.List_Search.List = Application.Transpose(TL) 'alimente la listbox "List_Search" avec le tableau TL transposé
End If

Il ne reste plus que la problématique des colonnes masquées.

Citation:

Envoyé par Thautheme

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Dim R As Range 'déclare la variable R (Recherche)
Dim TL() As Variant 'declare le tableau de lignes TL
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim PA As String 'déclare la variable PA (Première Adresse)
 
Me.List_Search.Clear 'efface le contenu de la listbox "List_Search"
Set R = Sheets("BDD").Range("A:A").Find(Me.TB_Nom.Value, LookIn:=xlValues) 'définit la recherche R
If Not R Is Nothing Then 'condition : si il existe au moin sune occurrence trouvée
    PA = R.Address 'définit l'adresse de la première occurrence trouvée
    I = 1 'initialise la variable I
    Do 'éxécute
        ReDim Preserve TL(10, 1 To I) 'redimensionne le tableau de lignes TL (11 lignes de 0 à 10, K colonnes)
        For J = 0 To 10 'boucles sur les 10 lignes de tableau de lignees TL
            TL(J, I) = R.Offset(0, J).Value 'récupère la valeur de l'occurrence trouvée décalée de J colonnes à droite
        Next J 'prochaine ligne de la boucle
        I = I + 1 'incrémente I (ajoute une colonne au tableau de lignes TL)
        Set R = Sheets("BDD").Range("a:a").FindNext(R) 'redéfinit la recherche R (occurrence suivante)
    Loop While Not R Is Nothing And R.Address <> PA 'boucle tant qu'il existe de nouvelles occurrences ailleurs qu'en PA
End If 'fin de la condition
If K > 1 Then 'condition : si K est supérieur à 1 (au moins une occurrence a été trouvée)
    'si K=2 (une seule occurrence trouvée), redimensionne le tableau TL pour permettre la tranposition (sinon plantage)
    If K = 2 Then ReDim Preserve TL(UBound(TL), 1 To 2)
    Me.List_Search.List = Application.Transpose(TL) 'alimente la listbox "List_Search" avec le tableau TL transposé
End If

[Édition]
Bonjour Docmarti, nous nous sommes croisé...

Citation:

Envoyé par Chris_Ewoks

Je continue de chercher des informations sur l'alimentation par List.

Regarde la section "Alimentation par List" sur la page de Boisgontier

Voici comment faire si le résultat ne contient qu'une ligne.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Private Sub BT_Search_Click()
 
Set f = Worksheets("BDD")
 
  Me.List_Search.Clear
  If Me.TB_Nom.Value = "" Then Exit Sub
  debut = 1
  col = 14
  dern = f.Cells(Rows.Count, 1).End(xlUp).Row
  ReDim xx(debut To col, debut To debut)
 
  For i = 2 To dern
   If f.Cells(i, 1) = Me.TB_Nom.Value Then
 
    trouv = trouv + 1
    ReDim Preserve xx(debut To col, debut To trouv)
 
    For j = 1 To col
     xx(j, trouv) = f.Cells(i, j)
    Next
 
   End If
  Next
 
    If trouv > 0 Then
     If trouv > 1 Then
        Me.List_Search.List = Application.Transpose(xx)
     Else
 
        ReDim aa(1 To 1, 1 To col)
        For j = 1 To col
         aa(1, j) = xx(j, 1)
        Next
        Me.List_Search.List = aa
     End If
  End If
 
 
End Sub

Docmarti, effectivement cela fonctionne maintenant correctement, je n'avais pas vu cette subtilité.

Concernant le problème d'affichage des colonnes, je l'ai résolu en ajoutant ColumnWidth sur ma liste définie.

Code:

Me.List_Search.ColumnWidths = "120;120;120;0;120;120;120;120;120;0;0;0;0"

Par contre, le problème d'index > 11 se pose toujours lorsque je double click sur une ligne de ma liste pour afficher toutes les valeurs dans un nouveau UserForm.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Private Sub List_Search_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
 
UF_Modify.TB_Nom.Value = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 0)
UF_Modify.TB_Prenom = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 1)
UF_Modify.TB_Age = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 2)
UF_Modify.CB_Parents = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 3)
UF_Modify.TB_Commune = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 4)
UF_Modify.TB_IN = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 5)
UF_Modify.TB_Contact = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 6)
UF_Modify.TB_OUT = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 7)
UF_Modify.TB_Nb_CS = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 8)
UF_Modify.CB_2012 = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 9)
UF_Modify.CB_2013 = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 10)
UF_Modify.CB_2014 = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 11)
UF_Modify.CB_2015 = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 12)
UF_Modify.CB_2016 = UF_Search.List_Search.List(UF_Search.List_Search.ListIndex, 13)
 
UF_Modify.Show
 
End Sub

07/08/2015, 15h12
Docmarti

Quel problème? En tout cas, cette procédure ne produit aucune erreur sur mon ordi.

1 pièce(s) jointe(s)

Re,

Ce que je fais c'est que je stocke le numéro de ligne dans la première colonne de la ListBox que je masque. Cela implique que la Listbox contienne une colonne de plus que le nombre de données stockées et que cette colonne soit masquée. Dans le code tu stocke avec TL(0, K) = R.Row. tu l'adapte pour ajouter une colonne en plus.
Ainsi j'obtiens :
Code:

1 2 3 4 5 6 7 8 9 Private Sub List_Search_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim LI As Integer LI = Me.List_Search.Column(0, Me.List_Search.ListIndex) With Sheets("BDD") UF_Modify.TB_Nom.Value = .Cells(LI, 1).Value 'etc... UF_Modify.Show End Sub
Re,

En adaptant ton fichier je viens de comprendre pourquoi tu avait remplacé K par R. En fait c'était par I qu'il fallait le faire... Désolé je n'avais pas testé avant d'envoyer le code
En pièce jointe ton fichier modifié. J'ai supprimé le bouton, le code s'exécute directement à l'édition dans la TextBox...

07/08/2015, 16h59
Chris_Ewoks

Merci Thautheme et Docmarti pour votre aide !
Cela fonctionne très bien et surtout j'ai compris le pourquoi de chaque ligne de code ...

A bientôt