Listes avec plusieurs colonnes

-Créer un nom de champ dynamique Maliste2col
=DECALER($A$2;;;NBVAL($A:$A)-1;2)
-Dans Rowsource:Maliste2col
-Spécifier ColumnCount:2 et ColumnWidth:40;70

ou en VBA

Private Sub UserForm_Initialize()
  Me.Choix.ColumnCount = 2
  Me.Choix.ColumnWidths = "40,70"
  Me.Choix.RowSource = "A2:B" & [B65000].End(xlUp).Row
End Sub

ou

Me.Choix2.ColumnCount = 2
Me.Choix2.ColumnWidths = "40,70"
Me.Choix2.List = [maListe2Col].value

Récupération du résultat

Private Sub Choix_Change()
   MsgBox Me.Choix                    ' 1ere colonne
   MsgBox Me.Choix.Column(1)    ' 2e colonne
   MsgBox Me.Choix.ListIndex      ' position
   MsgBox Me.Choix.List(Me.Choix.ListIndex, 0)     ' 1ere colonne
   MsgBox Me.Choix.List(Me.Choix.ListIndex, 1)      ' 2e colonne
End Sub

Listes avec plusieurs colonnes avec tableau

Le menu est alimenté par un tableau. -Liste2colonnesTableau.xls -

Private Sub UserForm_Initialize()
  Dim Tbl(1 To 7, 1 To 2)
    For j = 1 To 7
      Tbl(j, 1) = Format(Date + j - 1, "dddd")
      Tbl(j, 2) = Date + j - 1
   Next j
   Me.ListBox1.ColumnCount = 2
   Me.ListBox1.ColumnWidths = "40,60"
   Me.ListBox1.List = Tbl
End Sub

Récupération du résultat

Private Sub ListBox1_Click()
   Me.TextBox1 = Me.ListBox1.Column(1) ' 2e colonne
   Me.TextBox1 = Me.ListBox1.List(1, 1)   ' 2e colonne
End Sub

Récupération de la liste dans un tableau

Tbl = Me.ListBox1.List
MsgBox UBound(Tbl, 1)
MsgBox LBound(Tbl, 1)
MsgBox ListBox1.ListCount

Alimentation d'une ListBox avec Additem

ListeMultiColonnes.xls

Private Sub B_go_Click()
  Me.ListBox1.Clear
  Set c = Range("a:a").Find(Me.TextBox1.Value, LookIn:=xlValues)
  If Not c Is Nothing Then
     premier = c.Address
     i = 0
     Do
       Me.ListBox1.AddItem
       Me.ListBox1.List(i, 0) = c.Value
       Me.ListBox1.List(i, 1) = c.Offset(0, 1).Value
       Me.ListBox1.List(i, 2) = c.Offset(0, 2).Value
       Set c = Range("a:a").FindNext(c)
       i = i + 1
     Loop While Not c Is Nothing And c.Address <> premier
   End If
End Sub

Recherche par numéro de téléphone

Les numéros dans la colonne D sont sous forme numérique.
On effectue une recherche par numéro de téléphone. La recherche peut se faire sur une partie du numéro.

Private Sub B_ok_Click()
  Me.ListBox1.Clear
  j = 0
  For i = 2 To [d65000].End(xlUp).Row
    temp = Replace(Me.TextBox1, " ", "")
    If IsNumeric(temp) Then
      If Cells(i, 4) Like "*" & CDbl(temp) & "*" Then
        Me.ListBox1.AddItem
        Me.ListBox1.List(j, 0) = Cells(i, 2)
        Me.ListBox1.List(j, 1) = Cells(i, 3)
        Me.ListBox1.List(j, 2) = Format(Cells(i, 4), "00 00 00 00 00")
        j = j + 1
      End If
    End If
  Next i
End Sub

Remplissage à partir d'une liste d'un classeur fermé

Le classeur BDsource.xls contient:

Nom        Service
Dupont    Edudes
Durand    Compta

Private Sub UserForm_Initialize()
  repertoire = ThisWorkbook.Path & "\"
  classeur = "BDSource.xls"
  i = 2
  Do
    temp = Application.ExecuteExcel4Macro("'" & repertoire & "[" & classeur & "]feuil1'!R" & i & "C1")
    If temp <> 0 Then
      Me.ComboBox1.AddItem
      Me.ComboBox1.List(i - 2, 0) = temp
      Me.ComboBox1.List(i - 2, 1) = Application.ExecuteExcel4Macro("'" & repertoire & "[" & classeur & "]feuil1'!R" & i & "C2")
     i = i + 1
   End If
   Loop Until temp = 0
End Sub

Multi-Colonnes sans doublons trié

Private Sub UserForm_Initialize()
  Dim c()
  Set mondico = CreateObject("Scripting.Dictionary")
  temp = [B2:C1000]
  For i = 1 To UBound(temp, 1)
    x = temp(i, 1) & " - " & temp(i, 2)
    If temp(i, 1) <> "" Then
      If Not mondico.Exists(x) Then
        mondico.Add x, 1
      Else
        y = mondico.Item(x)
        mondico.Remove (x)
        mondico.Add x, y + 1
      End If
    End If
  Next i
  n = mondico.Count
  ReDim c(1 To n, 1 To 2)
  a = mondico.keys
  b = mondico.items
  For i = 1 To n
    c(i, 1) = a(i - 1)
    c(i, 2) = b(i - 1)
  Next i
  j = UBound(c, 1)
  Call tri2(c, 1, j)
  Me.ListBox2.List = c
End Sub

Sub tri2(a(), gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2, 1)
  g = gauc: d = droi
  Do
    Do While a(g, 1) < ref: g = g + 1: Loop
    Do While ref < a(d, 1): d = d - 1: Loop
    If g <= d Then
      temp = a(g, 1): a(g, 1) = a(d, 1): a(d, 1) = temp
      temp = a(g, 2): a(g, 2) = a(d, 2): a(d, 2) = temp
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call tri2(a, g, droi)
  If gauc < d Then Call tri2(a, gauc, d)
End Sub

Recherche multi-critères

Private Sub CommandButton1_Click()
  k = 0
  Me.ListBox1.Clear
  If Me.TextBox2 = "" Then Me.TextBox2 = "*"
  If Me.TextBox1 = "" Then Me.TextBox1 = "*"

For i = 2 To [A65000].End(xlUp).Row
  If Cells(i, 1) Like "*" & Me.TextBox1 & "*" _
     And Cells(i, 5) Like TextBox2 Then
    Me.ListBox1.AddItem
    Me.ListBox1.List(k, 0) = Cells(i, 1)
    Me.ListBox1.List(k, 1) = Cells(i, 2)
    Me.ListBox1.List(k, 2) = Cells(i, 3)
    Me.ListBox1.List(k, 3) = Cells(i, 4)
    Me.ListBox1.List(k, 4) = Cells(i, 5)
    Me.ListBox1.List(k, 5) = i
    k = k + 1
  End If
Next i
End Sub

Private Sub ListBox1_Click()
  ligne = ListBox1.Column(5)
  Rows(ligne).Select
End Sub

Recherche intuitive multi-colonnes

Le nombre de colonnes affichées dans le formulaire s'adapte au nombe de colonnes de la BD.

FormIntuitifMultiColonnes

Dim nbcol
Dim Lbl(1 To 15) As New ClasseSaisie
Private Sub UserForm_Initialize()
 Set f = Sheets("BD")
  nbcol = f.[A1].CurrentRegion.Columns.Count
  Me.ListBox1.ColumnCount = nbcol
  nbLig = f.[A1].CurrentRegion.Rows.Count - 1
  Me.ListBox1.List = f.[A1].CurrentRegion.Offset(1).Resize(nbLig).Value
  i = 1
  x = 15
  For i = 1 To nbcol
    retour = Me.Controls.Add("Forms.Label.1", "Label" & i, True)
    Me("label" & i).Caption = f.Cells(1, i)
    Me("label" & i).Top = 45
    Me("label" & i).Left = x
    x = x + f.Columns(i).Width * 1.1
    temp = temp & f.Columns(i).Width * 1.1 & ";"
  Next
  Me.ListBox1.ColumnWidths = temp
  For b = 1 To nbcol: Set Lbl(b).GrLabel = Me("Label" & b): Next b
End Sub

Private Sub TextBox1_Change()
  Me.ListBox1.Clear
  i = 0
  Set plage = f.[A1].CurrentRegion
  Set c = plage.Find(Me.TextBox1, , , xlPart)
  If Not c Is Nothing Then
     premier = c.Address
     Do
       Me.ListBox1.AddItem
       lig = c.Row - plage.Row + 1
       For col = 1 To nbcol
         Me.ListBox1.List(i, col - 1) = plage.Cells(lig, col)
       Next col
       i = i + 1
       Set c = plage.FindNext(c)
     Loop While Not c Is Nothing And c.Address <> premier
  End If
End Sub

Private Sub B_tout_Click()
   UserForm_Initialize
   For i = 1 To nbcol
     Me("label" & i).ForeColor = vbBlack
  Next i
End Sub

Private Sub B_recup_Click()
Sheets("Result").Cells.ClearContents
Sheets("Result").Range("A2").Resize(Me.ListBox1.ListCount, nbcol) = Me.ListBox1.List
For i = 1 To nbcol
Sheets("Result").Cells(1, i) = Me("label" & i).Caption
Sheets("Result").Cells(1, i).Font.Bold = True
Next
End Sub

Private Sub b_recupLigne_Click()
Sheets("Result").Cells.ClearContents
Sheets("Result").Range("A2").Resize(, nbcol) = _
Application.Index(Me.ListBox1.List, Me.ListBox1.ListIndex + 1)
For i = 1 To nbcol
Sheets("Result").Cells(1, i) = Me("label" & i).Caption
Sheets("Result").Cells(1, i).Font.Bold = True
Next
End Sub

Module de classe ClasseSaisie

Public WithEvents GrLabel As MSForms.Label
Private Sub GrLabel_Click()
nbcol = Sheets("bd").[A1].CurrentRegion.Columns.Count
temp = GrLabel.Name
col = Val(Mid(temp, 6))
If IsNumeric(f.Cells(2, col)) Then num = True Else num = False
For i = 1 To nbcol
UserForm1("label" & i).ForeColor = vbBlack
Next i
UserForm1(temp).ForeColor = vbRed
Dim a()
a = UserForm1.ListBox1.List
nbcol = UBound(a, 2) - LBound(a, 2) + 1
If col <> OrdreAncien Then ordre = False
Call TriCD(a(), UBound(a), col - 1, Not ordre, nbcol, num)
ordre = Not ordre
OrdreAncien = col
UserForm1.ListBox1.List = a
End Sub

Tri ListBox MultiColonnes rapide

TriListBoxMultiColonnes rapide

Private Sub UserForm_Initialize()
  With Sheets("Feuil1")
      Me.ListBox1.List = .Range("A2:C" & .[A65000].End(xlUp).Row).Value
  End With
End Sub

Private Sub LTriNom_Click()
   Dim a()
   a = Me.ListBox1.List
   NbCol = UBound(a, 2) - LBound(a, 2) + 1
   Call tri(a(), LBound(a), UBound(a), NbCol, 0)
   Me.ListBox1.List = a
End Sub

Private Sub LTriVille_Click()
   Dim a()
   a = Me.ListBox1.List
   NbCol = UBound(a, 2) - LBound(a, 2) + 1
   Call tri(a(), LBound(a), UBound(a), NbCol, 1)
   Me.ListBox1.List = a
End Sub

Private Sub LCP_Click()
    Dim a()
    a = Me.ListBox1.List
    NbCol = UBound(a, 2) - LBound(a, 2) + 1
    Call tri(a(), LBound(a), UBound(a), NbCol, 2)
    Me.ListBox1.List = a
End Sub

Sub tri(a(), gauc, droi, NbCol, colTri) ' Quick sort
   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 = 0 To NbCol - 1
             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, NbCol, colTri)
   If gauc < d Then Call tri(a, gauc, d, NbCol, colTri)
End Sub

Titres colonnes

Génère des titres de colonnes d'un ListBox. TitresColonnes

Noms de champ à créer
MaBD =DECALER($A$2;;;NBVAL($A:$A)-1;NBVAL($1:$1))

Private Sub UserForm_Initialize()
  nbcol = [MaBD].Columns.Count
  Me.ListBox1.ColumnCount = nbcol
  Me.ListBox1.List = [MaBD].Value
  i = 1
  x = 15
  For i = 1 To nbcol
    retour = Me.Controls.Add("Forms.Label.1", "Label" & i, True)
    Me("label" & i).Caption = Cells(1, i)
    Me("label" & i).Top = 10
    Me("label" & i).Left = x
    x = x + Columns(i).Width * 1.1
    temp = temp & Columns(i).Width * 1.1 & ";"
  Next
  Me.ListBox1.ColumnWidths = temp
End Sub