[Résolu] Transfert LitBox vers TextBox

Kim75 · 18 Octobre 2016

Bonsoir le forum,

Le code testé sur 40 lignes fonctionne sans encombre, mais rame sans fin avec 1700 lignes
Quelqu'un pourrait-il m'indiquer une bonne façon d'alimenter cette ListBox triée alphabétiquement :

VB:

Private Sub UserForm_Initialize()
Dim wsBD As Worksheet, lastCell As Integer, lastRow As Integer, x As Integer
Dim i As Long, j As Long, Temp As Variant
Set wsBD = ThisWorkbook.Sheets("BD")
lastRow = wsBD.Range("A" & Rows.Count).End(xlUp).Row
For x = 1 To lastRow
    Me.ListBox1.AddItem wsBD.Cells(x, wsBD.Cells(x, Columns.Count).End(xlToLeft).Column).Value
Next x
With ListBox1
    For i = 0 To .ListCount - 2
        For j = i + 1 To .ListCount - 1
            If .List(i) > .List(j) Then
                Temp = .List(j)
                .List(j) = .List(i)
                .List(i) = Temp
            End If
        Next j
    Next i
End With
End Sub

Par avance, merci !

BOISGONTIER · 19 Octobre 2016

Bonjour,

-La méthode de tri utilisée est très lente
-Il ne faut pas trier directement le ListBox mais utiliser un Array

cf PJ

JB

belkacem_64 · 19 Octobre 2016

Salut
ce code est un peut rapide

Private Sub UserForm_Initialize()

Application.ScreenUpdating = False
Dim wsBD As Worksheet, lastCell As Integer, lastRow As Integer, x As Integer
Dim i As Long, j As Long, Temp As Variant

Set wsBD = ThisWorkbook.Sheets("BD")
lastRow = wsBD.Range("A" & Rows.Count).End(xlUp).Row
wsBD.Range("O1:O" & wsBD.Range("O" & Rows.Count).End(xlUp).Row+1).ClearContents

For x = 1 To lastRow
wsBD.Cells(x, "o") = wsBD.Cells(x, wsBD.Cells(x, Columns.Count).End(xlToLeft).Column).Value
Next x
wsBD.Range("O1:O" & wsBD.Range("O" & Rows.Count).End(xlUp).Row).Sort , Key1:=wsBD.Range("O1"), Order1:=xlAscending
ListBox1.List = wsBD.Range("O1").Resize(Cells(Rows.Count, 15).End(xlUp).Row, 1).Value

wsBD.Range("O1:O" & wsBD.Range("O" & Rows.Count).End(xlUp).Row+1).ClearContents
Application.ScreenUpdating = True

End Sub

Kim75 · 19 Octobre 2016

Bonjour le forum,

Je remercie infiniment JB et Belkacem
Sans cela j'attendais des heures pour voir la listbox s'afficher

Bonne journée à tous !!!

Kim75 · 22 Octobre 2016

Bonsoir le forum,

Le récent coup de main de Jacques (merci !) m'a permis d'avoir cette ListBox un peu particulière

Il me reste juste à repérer dans la feuille Excel toutes les cellules, jusqu'à la première, qui précédent horizontalement l'item sélectionné de la ListBox

A partir de cette de plage de cellules, prise comme critère, collecter toutes les lignes de la feuille Excel ayant cette même plage horizontale de cellules

Et en dernier lieu, lister dans un TextBox les valeurs de cette collection se trouvant dans la colonne de l'item ListBox sélectionné, ci-joint le fichier illustré

Merci par avance de votre aide.

Bebere · 23 Octobre 2016

bonjour Kim.Belkacem.JB
si bien compris la demande

Code:

Private Sub ListBox1_Click()
    Dim x As Long, MyLig As Long, MyCol As Long, Ligne As Range, cel As Range, c As Byte
    For x = 1 To ListBox1.ListCount
        If ListBox1.Selected(x) = True Then
            MyLig = ListBox1.List(x, 0)
            MyCol = ListBox1.List(x, 2)
            Me.TextBox1 = ""
            Set Ligne = f.Range(Cells(MyLig, 1), Cells(MyLig, MyCol))
            For Each cel In Ligne
                If cel = cel.Offset(-1, 0) Then c = c + 1
            Next cel
            If c < MyCol - 1 Then
                c = 0
                For Each cel In Ligne
                    If cel = cel.Offset(1, 0) Then c = c + 1
                Next cel
            End If
            If c = MyCol - 1 Then TextBox1.Text = Me.ListBox1.List(Me.ListBox1.ListIndex, 1)
        End If
    Next x
End Sub

Kim75 · 23 Octobre 2016

Bonjour Bebere, le forum,

Merci pour ta proposition, mais c'est pas tout à fait ça, enfin presque
Lorsqu'on clique sur l'item G4, ça affiche uniquement G4 dans le TextBox
Alors qu'il faudrait que ça affiche les trois valeurs ensemble : G4, G5 et G6
Parce que ces 3 items de la ListBox répondent à la même condition : une même arborescence horizontale à partir de la colonne (1) jusqu'à la colonne (MyCol - 1)

PS : J'ai dû ajouter une ligne d'en-têtes dans le tableau, et décaler la base de données d'une ligne vers le bas, car le click sur l'item correspondant à la première ligne (1) d'Excel provoquait une erreur

Amicalement !

Bebere · 23 Octobre 2016

Kim
un autre code

Code:

Private Sub ListBox1_Click()
    Dim f As Worksheet, x As Long, MyLig As Long, L As Long, Lig As Long, MyCol As Long, NbX As Long, Ligne(), col As Byte, c As Byte
    Dim a As String
    Set f = ThisWorkbook.Sheets("BD")
    For x = 1 To ListBox1.ListCount
        If ListBox1.Selected(x) = True Then
            MyLig = ListBox1.List(x, 0)
            MyCol = ListBox1.List(x, 2)
            Me.TextBox1 = ""
            Lig = f.Columns(1).Find(Cells(MyLig, 1), LookIn:=xlValues).Row
            c = Application.CountIf(f.Range("A:A"), f.Cells(MyLig, 1))
            Ligne = f.Range(Cells(Lig, 1), Cells(Lig + c - 1, MyCol - 1))
            '           NbX = Application.SumProduct(Right(Ligne, 1) = Right(f.Cells(MyLig, 1), 1))
            For L = 1 To UBound(Ligne, 1)
                For col = 1 To UBound(Ligne, 2)
                    If Right(Ligne(L, col), 1) = Right(f.Cells(MyLig, 1), 1) Then
                        NbX = NbX + 1
                    End If
                Next col
                a = a & f.Cells(L + Lig - 1, MyCol) & " "
            Next L
            If NbX = c * (MyCol - 1) Then TextBox1.Text = a
        End If

    Next x
End Sub

Kim75 · 23 Octobre 2016

Hello Bebere, le forum,

C'est étrange, cette seconde méthode fonctionne impeccablement sur la BD fournie en exemple, 44 lignes, mais reste bizarrement muette sur la BD de 1700 lignes avec des Noms, Prénoms, Services, etc, le click sur l'item ListBox n'affiche rien dans le TextBox qui reste blanc

Alors que la première méthode a l'air de bien supporter la base réelle de 1700 lignes, puisque le click sur l'item ListBox affiche tout de même bien sa propre valeur, le souci est qu'il n'affiche pas les autres valeurs de sa famille, je ne sais pas pourtant j'ai augmenté le type/capacité des variables

Pour tester cette seconde méthode, j'ai supprimé une très grande partie des données réelles (1700 lignes) pour ne laisser que 44 lignes, juste pour voir, et là même avec ces 44 lignes et ça ne fonctionne pas, soit ça reste blanc, soit ça provoque des erreurs, soit ça affiche l'item lui même plusieurs fois

Bien à toi, Kim.

laetitia90 · 24 Octobre 2016

bonjour tous

essai deja de charger la listbox comme cela en passant par un " tablo"

Code:

 Dim t(), x As Long, i As Long, y As Long, z, a
Private Sub UserForm_Initialize()
t = Feuil1.Range("a2:n" & Feuil1.Cells(Rows.Count, 1).End(3).Row)
For i = 1 To UBound(t)
z = Cells(i + 1, Columns.Count).End(xlToLeft).Column
a = Cells(i, Columns.Count).End(xlToLeft).Column
x = x + 1
t(x, 1) = i: t(x, 2) = t(i, z): t(x, 3) = z
If a = z Then t(x - 1, 4) = i
If a <> z Then t(x, 4) = t(x, 2)
Next i
ListBox1.ColumnCount = 4
ListBox1.ColumnWidths = "40;60;25"
  Call Tri(t, LBound(t), UBound(t), 2)
  ListBox1.List = t
End Sub
Private Sub ListBox1_Click()
With ListBox1
If Not IsNumeric(.List(.ListIndex, 3)) Then TextBox1 = .List(.ListIndex, 3) Else TextBox1 = "": Exit Sub
End With
End Sub
Sub Tri(a, gauc, droi, colTri)
    Dim ref, g, d, c, temp
    ref = a((gauc + droi) \ 2, colTri)
    g = gauc: d = droi
    Do
        Do While a(g, colTri) < ref: g = g + 1: Loop
        Do While ref < a(d, colTri): d = d - 1: Loop
        If g <= d Then
            For c = LBound(a, 2) To UBound(a, 2)
                temp = a(g, c): a(g, c) = a(d, c): a(d, c) = temp
            Next
            g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call Tri(a, g, droi, colTri)
    If gauc < d Then Call Tri(a, gauc, d, colTri)
End Sub

apres on verra si cela est rapide tu remarque dans la listbox... 4 colonnes si on veut pas la voir la derniere on affiche 3
dans l'exemple je traite uniquement si pas de suite " les not numeric"
mais bon sans savoir si le chargement est rapide traitement a la source ou listbox click

laetitia90 · 24 Octobre 2016

re, la presentation du forum encore change

Bebere · 24 Octobre 2016

bonjour Kim,Laetitia
Laetitia a raison c'est mieux avec un tableau

Code:

Option Explicit
Dim Tbl()
Private Sub UserForm_Initialize()
    Dim f As Worksheet, lastRow As Integer, x As Integer, i As Long
    
    ListBox1.ColumnCount = 3
    ListBox1.ColumnWidths = "40;60;25"
    lastRow = f.Range("A" & Rows.Count).End(xlUp).Row
    ReDim Tbl(1 To lastRow - 1, 1 To 3)
    For x = 2 To lastRow
        Tbl(x - 1, 1) = x - 1
        Tbl(x - 1, 2) = f.Cells(x, f.Cells(x, Columns.Count).End(xlToLeft).Column).Value
        Tbl(x - 1, 3) = f.Cells(x, f.Columns.Count).End(xlToLeft).Column
    Next x
    Call Tri(Tbl, LBound(Tbl), UBound(Tbl), 1)
    Me.ListBox1.List = Tbl
    Tbl = f.Range("A2:N" & lastRow)
    Liste.Caption = ListBox1.ListCount & " lignes dans la liste"
End Sub

Private Sub ListBox1_Click()
    Dim f As Worksheet, x As Long, MyLig As Long, L As Long, Lig As Long, MyCol As Long, NbX As Long, Ligne(), col As Byte, c As Byte
    Dim a As String
    Set f = ThisWorkbook.Sheets("BD")
    For x = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(x) = True Then
            MyLig = ListBox1.List(x, 0)
            MyCol = ListBox1.List(x, 2)
            Me.TextBox1 = ""
            For L = 1 To UBound(Tbl, 1)
                If Tbl(L, 1) = Tbl(MyLig, 1) Then
                    If Lig = 0 Then Lig = L
                    c = c + 1
                End If
            Next L
            For L = Lig To Lig + c - 1
                For col = 1 To MyCol - 1
                    If Right(Tbl(L, col), 1) = Right(Tbl(MyLig, 1), 1) Then
                        NbX = NbX + 1
                    End If
                Next col
                a = a & Tbl(L, MyCol) & " "
            Next L
            If NbX = c * (MyCol - 1) Then TextBox1.Text = a
        End If

    Next x
End Sub

Kim75 · 24 Octobre 2016

Bonsoir Laetitia, Bebere, Belkacem, Jacques, le forum

Merci Laetitia pour ton aide, et encore Merci Bebere de t'être penché sur ce problème
Grâce à vous tout fonctionne nickel, sans oublier naturellement Jacques et Belkacem

Amicalement, Kim.

[Résolu] Transfert LitBox vers TextBox

Kim75

XLDnaute Occasionnel

Pièces jointes

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

belkacem_64

XLDnaute Junior

Kim75

XLDnaute Occasionnel

Kim75

XLDnaute Occasionnel

Pièces jointes

Bebere

XLDnaute Barbatruc

Kim75

XLDnaute Occasionnel

Pièces jointes

Bebere

XLDnaute Barbatruc

Kim75

XLDnaute Occasionnel

Pièces jointes

laetitia90

XLDnaute Barbatruc

laetitia90

XLDnaute Barbatruc

Bebere

XLDnaute Barbatruc

Kim75

XLDnaute Occasionnel

Discussions similaires