Alimenter listbox 2 colonnes

Bonjour,

J'ai actuellement un problème pour alimenter une listbox à 2 colonnes, de base j'avais qu'une colonne et mon code était celui-ci (ça marche très bien) :

Sub Alimenter_LstbxDateRDV()

Dim ws As Worksheet
Dim Base As New Scripting.Dictionary
Dim Tableau()
Dim LastRow As Long
Dim i As Integer
Dim c As Variant
Dim NbrListe As Integer

Set ws = ThisWorkbook.Sheets("BDD")
Set Base = CreateObject("Scripting.Dictionary")

LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow
    If ws.Cells(i, 3) = uf_Prospection.tb_NomProspectionSup.Text Then
        c = CStr(ws.Cells(i, 37).Value)
            If Not Base.Exists(c) Then
                Base.Add c, c
            End If
    End If
Next i

uf_Prospection.Lstbx_DateRDV.List = Base.Keys

Set ws = Nothing
Set Base = Nothing

End Sub

Je n'arrive pas à insérer une 2ème colonne, j'ai essayé en modifiant un peu le code avec :

uf_Prospection.Lstbx_DateRDV.List(, 1) = Base.Keys
uf_Prospection.Lstbx_DateRDV.List(, 2) = "test"

Avez-vous une solution ?

Merci,

Bonjour,

ci-jointe proposition

Sub Alimenter_LstbxDateRDV()

    Dim ws As Worksheet
    Dim Base As Object
    Dim Tableau()
    Dim LastRow As Long
    Dim i As Integer
    Dim clé As Variant
    Dim NbrListe As Integer

    Set ws = ThisWorkbook.Sheets("BDD")
    Set Base = CreateObject("Scripting.Dictionary")

    LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To LastRow
        If ws.Cells(i, "C") = uf_Prospection.tb_NomProspectionSup.Text Then
            clé = CStr(ws.Cells(i, "AJ").Value)
            If Not Base.Exists(clé) Then Base(clé) = Array(clé, "test")
        End If
    Next i

    With uf_Prospection.Lstbx_DateRDV
        .ColumnCount = 2
        .Column = Application.Transpose(Base.items)
    End With

    Set ws = Nothing
    Set Base = Nothing

End Sub

Bonjour thev,

merci pour ta réponse ça marche bien, sauf pour une chose:

Le code sert à alimenter une listbox que voici :

La listbox est alimenté quand je clique sur un élément de la liste d'entreprise. Mais j'ai une erreur lorsque je clique sur une entreprise qui n'a pas de "Date dernière visite"

J'ai une erreur d'incompatibilité "13"

le code :

Sub Alimenter_LstbxDateRDV()

    Dim ws As Worksheet
    Dim Base As Object
    Dim Tableau()
    Dim LastRow As Long
    Dim i As Integer
    Dim DateCR As Variant, ProspectionType As Variant, Prospection As Variant
    Dim NbrListe As Integer

    Set ws = ThisWorkbook.Sheets("BDD")
    Set Base = CreateObject("Scripting.Dictionary")

    LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To LastRow
        If ws.Cells(i, 3) = uf_Prospection.tb_NomProspectionSup.Text Then
            If ws.Cells(i, 37).Value <> "" Then
                DateCR = CStr(ws.Cells(i, 37).Value)
            Else: DateCR = "Pas encore de visite"
            End If
            ProspectionType = CStr(ws.Cells(i, 44).Value)
            Select Case ProspectionType
                Case "PROSPECTION TELEPHONIQUE"
                    Prospection = "Téléphone"
                Case "Prospection - Visite"
                    Prospection = "Visite"
                Case "Prospection - Qualification"
                    Prospection = "Visite"
            End Select
            If Not Base.Exists(DateCR) Then
                Base(DateCR) = Array(DateCR, Prospection)
            End If
        End If
    Next i

    With uf_Prospection.Lstbx_DateRDV
        .ColumnCount = 2
        .Column = Application.Transpose(Base.Items)
    End With

    Set ws = Nothing
    Set Base = Nothing

End Sub

L'erreur est dans les dernière lignes :

        .Column = Application.Transpose(Base.Items)

J'ai mis en PJ un fichier anonymisé, merci !

Bonjour,

apporter cette modification

    With uf_Prospection.Lstbx_DateRDV
        .ColumnCount = 2
        If Base.Count > 0 Then .Column = Application.Transpose(Base.Items)
    End With

Par ailleurs, vous employez des tableaux structurés. Ce type de tableau ne doit pas de comporter de lignes vides pour son utilisation : code, tri, filtre, TCD, PowerQuery,... Tout ajout d'une nouvelle ligne recopie format et formules.

thev a écrit :

Bonjour,

apporter cette modification

    With uf_Prospection.Lstbx_DateRDV
        .ColumnCount = 2
        If Base.Count > 0 Then .Column = Application.Transpose(Base.Items)
    End With

Par ailleurs, vous employez des tableaux structurés. Ce type de tableau ne doit pas de comporter de lignes vides pour son utilisation : code, tri, filtre, TCD, PowerQuery,... Tout ajout d'une nouvelle ligne recopie format et formules.

Ca marche parfaitement, merci !