[Résolu] Transfert LitBox vers TextBox

Kim75

XLDnaute Occasionnel
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 !
 

Pièces jointes

  • Test.xlsm
    23.8 KB · Affichages: 60
Dernière édition:

belkacem_64

XLDnaute Junior
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
 
Dernière édition:

Kim75

XLDnaute Occasionnel
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.
 

Pièces jointes

  • Test_V2.xlsm
    27.1 KB · Affichages: 59

Bebere

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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 !
 

Pièces jointes

  • Test_V3.xlsm
    28.9 KB · Affichages: 61
Dernière édition:

Bebere

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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.
 

Pièces jointes

  • Test_V4.xlsm
    29.4 KB · Affichages: 74
Dernière édition:

laetitia90

XLDnaute Barbatruc
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
 

Bebere

XLDnaute Barbatruc
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
 

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
312 922
Messages
2 093 644
Membres
105 775
dernier inscrit
assen