Formulaire liste multi-colonnes

Accueil

Liste plusieurs colonnes
Liste plusieurs colonnes avec tableau
Liste plusieurs colonnes avec AddItem
Alimentation d'un Listbox par List
Alimenter ListBox avec BD sans lignes vides & ListBox conditionnelle
Suppression de ligne avec RemoveItem
En-tête colonnes ListBox
ListBox comboBox Intuitif
Tri multi-colonnes pour ListBox avec SortedList
Alimenation combobox avec colonnes discontinues
ListBox avec plus de 10 colonnes
Recherche numéro téléphone
ListBox avec sélection triée
Recherche sur les premières lettres
Listbox multi-colonnes trié
Multi colonnes sans doublons trié
Listes triées multicolonnes et multi critères
Recherche multi-critère
Recherche intuitive multicolonnes
Recherche intuitive multi-colonnes multi-mots
Tri ListBox multiColonnes rapide
Colonne partiellement masquée
Tri de ListBox
Liste des fichiers d'un répertoire

Listes avec plusieurs colonnes

2 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)   ' 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

Alimentation par List

C'est la méthode la plus rapide.

ListBox Mult-iColonnes

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

Récupérer la ligne sélectionnée dans un ListBox

Private Sub ListBox1_Click()
  Tbl = Application.Index(Me.ListBox1.List, Me.ListBox1.ListIndex + 1)
  MsgBox Join(Tbl, ",")
End Sub

Saisie intuitive avec TextBox et ListBox

Sur cet exemple,l'opérateur frappe les prmiers caractères du nom dans un textbox. La listbox est mise à jour au fur et à mesure de la frappe des caractères.

ListBox Mult-iColonnes TextBox Intuitif.xls
ListBox Mult-iColonnes TextBox Intuitif Ville.xls
ListBox une colonne Plusieurs mots

Dim f, bd()
  Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  bd = f.Range("a2:c" & [a65000].End(xlUp).Row).Value
  Me.ListBox1.List = bd
End Sub

Private Sub TextBox1_Change()
  clé = "*" & UCase(Me.TextBox1) & "*"
  Dim Tbl()
  n = 0: ncol = UBound(bd, 2)
  For i = LBound(bd) To UBound(bd)
     If UCase(bd(i, 1)) Like clé Then
        n = n + 1: ReDim Preserve Tbl(1 To ncol, 1 To n)
        For k = 1 To ncol: Tbl(k, n) = bd(i, k): Next
     End If
   Next i
   If n > 0 Then
      ReDim Preserve Tbl(1 To ncol, 1 To n + 1)
      Me.ListBox1.List = Application.Transpose(Tbl)
      Me.ListBox1.RemoveItem n
   End If
End Sub

Piège avec la propriété List

List attend un tableau 2D.

Si n=1 dans le tableau Tbl(1 To ncol, 1 To n)
ApplicationTranspose(Tbl) génère un tableau à 1 dimension X(1 To ncol)

Pour que n soit au moins égal à 2, on modifie sa dimension de 1.

n = n + 1: ReDim Preserve Tbl(1 To ncol, 1 To n)

puis on supprime l'item supplémentaire dans le ListBox

Me.ListBox1.RemoveItem n

Transfert BD dans un ListBox sans les lignes vides & ListBox conditionnelle

TransfertBD sans lignes vides dans ListBox
ListBox conditionnelle
TransfertBD sans lignes vides dans ListBox Trié Dictionary
TransfertBD sans lignes vides dans ListBox Trié ArrayList

Avec AddItem (6 sec pour 10.000 lignes)

Private Sub UserForm_Initialize()
  a = [A2:D10000].Value
  j = 0
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then
       Me.ListBox1.AddItem a(i, 1)
       Me.ListBox1.List(j, 1) = a(i, 2)
       Me.ListBox1.List(j, 2) = a(i, 3)
       Me.ListBox1.List(j, 3) = a(i, 4)
       j = j + 1
     End If
  Next i
End Sub

Suppression dans le ListBox (1 seconde 10.000 lignes et 3000 lignes vides)

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set d = CreateObject("Scripting.Dictionary")
  a = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  Me.ListBox1.List = a
  For i = ListBox1.ListCount - 1 To 0 Step -1
     If ListBox1.List(i) = "" Then ListBox1.RemoveItem (i)
  Next i
End Sub

Avec Dictionary (0,2 sec pour 10.000 lignes)

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set d = CreateObject("Scripting.Dictionary")
  a = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then d(i) = Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4))
  Next i
  n = d.Count
  If n > 0 Then ' gestion 1 seule ligne dans la BD
    Dim Tbl: Tbl = Application.Transpose(d.items)
    ReDim Preserve Tbl(1 To 4, 1 To n + 1)
    Me.ListBox1.List = Application.Transpose(Tbl)
    Me.ListBox1.RemoveItem n 
  End If
End Sub

Avec ArrayList (0,5 sec pour 10.000 lignes)

Private Sub UserForm_Initialize()
  Set AL = CreateObject("System.Collections.ArrayList")
  a = [A2:D10000].Value
  For i = LBound(a) To UBound(a)
     If a(i, 1) <> "" Then AL.Add Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4))
  Next i
  Me.ListBox1.List = Application.Transpose(Application.Transpose(AL.toarray))
End Sub

Autre méthode (0,2 sec pour 10.000 lignes)

Private Sub UserForm_Initialize()
  a = [A2:D7].Value
  Dim tmp(): ReDim tmp(1 To UBound(a))
  For i = LBound(a) To UBound(a) ' sup lignes vides de a(,)
    If a(i, 1) <> "" Then n = n + 1: tmp(n) = i
  Next
  ReDim Preserve tmp(1 To n)
  Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _
    Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
End Sub

Listbox multi-colonnes trié avec SortedList

Tri SortedList

Private Sub UserForm_Initialize()
  Set f = Sheets("bd2")
  a = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 1) & a(i, 2), i
  Next i
  For lig = LBound(a) To UBound(a)
    For col = LBound(a, 2) To UBound(a, 2)
      b(lig, col) = a(SL.GetByIndex(lig - 1), col)
    Next col
  Next lig
  Me.ListBox1.List = b
End Sub

Suppression de ligne dans ListBox (RemoveItem)

Form RemoveItem
Form Cascade RemoveItem

Option Compare Text
Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  a = f.Range("a2:a" & f.[A65000].End(xlUp).Row) ' tableau a(n,1) pour rapidité
  Call Tri(a, LBound(a), UBound(a))
  Me.ListBox1.List = a
End Sub

Private Sub ListBox1_Click()
  Set c = f.[A:A].Find(what:=Me.ListBox1)
  If Not c Is Nothing Then
    Me.TextBox1 = f.Cells(c.Row, 1)
    Me.TextBox2 = f.Cells(c.Row, 2)
    Me.TextBox3 = f.Cells(c.Row, 3)
    Me.TextBox4 = f.Cells(c.Row, 4)
    Me.TextBox5 = f.Cells(c.Row, 5)
  End If
End Sub

Private Sub B_sup_Click()
     If Me.ListBox1.ListIndex = -1 Then Exit Sub
     Set c = f.[A:A].Find(what:=Me.ListBox1)
     If Not c Is Nothing Then
        c.EntireRow.Delete
        MsgBox "Ligne sup"
        Me.ListBox1.RemoveItem Me.ListBox1.ListIndex
     End If
End Sub

En têtes de colonnes pour ListBox

ListBox en-têtes
ListBox en-têtes Cave Vins

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  nbcol = f.[A1].CurrentRegion.Columns.Count
  Me.ListBox1.ColumnCount = nbcol
  Set plage = f.[A1].CurrentRegion
  Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1)
  Me.ListBox1.List = plage.Value
  x = 15
  y = Me.ListBox1.Top - 12
  For i = 1 To nbcol
    Set Lab = Me.Controls.Add("Forms.Label.1")
    Lab.Caption = f.Cells(1, i)
    Lab.Top = y
    Lab.Left = x
    x = x + f.Columns(i).Width * 1.1
    temp = temp & f.Columns(i).Width * 1.1 & ";"
  Next
  Me.ListBox1.ColumnWidths = temp
End Sub

En tête de colonnes ListBox avec Scroll horizontal du Listbox dans un Frame

ListBox en-têtes Scroll

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  nbcol = f.[A1].CurrentRegion.Columns.Count
  Me.ListBox1.ColumnCount = nbcol
  Set plage = f.[A1].CurrentRegion
  Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1)
  Me.ListBox1.List = plage.Value
  x = 15
  y = Me.ListBox1.Top - 12
  For i = 1 To nbcol
    Set Lab = Me.Frame1.Controls.Add("Forms.Label.1")
    Lab.Caption = f.Cells(1, i)
    Lab.Top = y
    Lab.Left = x
    x = x + f.Columns(i).Width * 1.02
    temp = temp & f.Columns(i).Width * 1.02 & ";"
  Next
  Me.ListBox1.ColumnWidths = temp
  Me.Frame1.Width = 300
  Me.Frame1.ScrollWidth = Me.ListBox1.Width + 10
  Me.Frame1.ScrollBars = 1
End Sub

ListBox & Combobox Intuitif

Sur cet exemple, l'opérateur frappe les premiers caractères du nom dans un ComboBox. Le ComboBox et la Listbox sont mis à jour au fur et à mesure de la frappe des caractères.
Un double-clic dans le comboBox donne la liste triée de tous les noms.

ListBox Mult-iColonnes Combobox Intuitif.xls
ListBox Mult-iColonnes ComboBox Intuitif2.xls
Form ComboBox Intuitif pilote Filtre Automatique.xls
Form ComboBox Intuitif pilote Filtre Automatique2.xls

Dim f, bd()
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  bd = f.Range("a2:d" & [a65000].End(xlUp).Row).Value
  Me.ListBox1.List = bd
  Set d1 = CreateObject("scripting.dictionary")
  For i = 1 To UBound(bd)
     If bd(i, 1) <> "" Then d1(bd(i, 1)) = ""
  Next i
  a = d1.keys
  Call tri(a, LBound(a), UBound(a))
  Me.ComboBox1.List = a
End Sub

Private Sub ComboBox1_Change()
  Set d1 = CreateObject("scripting.dictionary")
  clé = UCase(Me.ComboBox1) & "*"
  Dim Tbl()
  n = 0: ncol = UBound(bd, 2)
  For i = LBound(bd) To UBound(bd)
     If UCase(bd(i, 1)) Like clé Then
        n = n + 1: ReDim Preserve Tbl(1 To ncol, 1 To n)
        For k = 1 To ncol: Tbl(k, n) = bd(i, k): Next
          If bd(i, 1) <> "" Then d1(bd(i, 1)) = ""
        End If
   Next i
   If n > 0 Then
      ReDim Preserve Tbl(1 To ncol, 1 To n + 1)
      Me.ListBox1.List = Application.Transpose(Tbl)
      Me.ListBox1.RemoveItem n
   End If
   a = d1.keys
   Call tri(a, LBound(a), UBound(a))
   Me.ComboBox1.List = a
   Me.ComboBox1.DropDown
End Sub

Pour récupérer le résultat de l'interrogation dans une feuille Result

Private Sub B_recup_Click()
  nbcol = UBound(bd, 2)
  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

ListBox & Combobox Intuitif et modification des enregistrements

ListBox Mult-iColonnes ComboBox Intuitif Modif

Alimenter un combobox par des colonnes discontinues

On veut alimenter une colonne de combobox par la concaténation des colonnes A et C du tableur.

FiltreArrayCol

Private Sub UserForm_Initialize()
  Set f = Sheets("bd3")
  Me.ComboBox1.List = Evaluate("=A2:A" & f.[A65000].End(xlUp).Row + 1 & "&char(32)&C2:C" &       f.[A65000].End(xlUp).Row + 1)
   Me.ComboBox1.RemoveItem Me.ComboBox1.ListCount - 1
End Sub

On veut alimenter 3 colonnes de combobox par les colonnes A ,C et D du tableur.

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set Rng = f.Range("A2:D" & f.[A65000].End(xlUp).Row + 1)
  Me.ComboBox1.List = Application.Index(Rng, Evaluate("Row(1:" & Rng.Rows.Count & ")"), Array(1, 3, 4))
  Me.ComboBox1.RemoveItem Me.ComboBox1.ListCount - 1
End Sub

ou

Private Sub UserForm_Initialize()
  Set f = Sheets("bd2")
  a = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  Me.ComboBox1.List = FiltreArrayCol(a, Array(1, 3, 4))
End Sub

Function FiltreArrayCol(tableau, ColResult)
  Dim b()
  ReDim b(LBound(tableau) To UBound(tableau), 1 To UBound(ColResult) - LBound(ColResult) + 1)
  decal = 1 - LBound(ColResult)
  For i = LBound(tableau, 1) To UBound(tableau, 1)
     For c = LBound(ColResult) To UBound(ColResult)
        b(i, c + decal) = tableau(i, ColResult(c))
     Next c
   Next i
   FiltreArrayCol = b
End Function

Recherche par nom +prénom

Recherche Nom + prénom


Option Compare Text
Dim f, ligneEnreg, Tblclé(), tblBD()
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Tblclé = Range("A2:B" & [A65000].End(xlUp).Row).Value ' Nom+Prénom
  tblBD = Range("A2:G" & [A65000].End(xlUp).Row).Value ' BD
  Call Tri(Tblclé, LBound(Tblclé), UBound(Tblclé))
  Me.ChoixNom.List = Tblclé
End Sub

ListBox avec plus de 10 colonnes

Additem n'accepte pas plus de 10 colonnes. Il faut alimenter la ListBox par un tableau 2D.

Dim a(), f
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  a = f.Range("A2:M" & f.[M65000].End(xlUp).Row).Value
  Me.ListBox1.List = a()
End Sub

Dans l'exemple ci dessous, nous créons un tableau a() avec les factures du client choisi.

ListBox12

Dim bd, f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set d = CreateObject("Scripting.Dictionary")
  Set bd = f.Range("A2:M" & f.[M65000].End(xlUp).Row)
  For i = 1 To bd.Rows.Count
     If bd.Cells(i, 1) <> "" Then d(bd.Cells(i, 1).Value) = ""
   Next i
   temp = d.keys
   Call Tri(temp, LBound(temp), UBound(temp))
   Me.ComboBox1.List = temp
   Me.ListBox1.List = bd.Value
   For k = 1 To 13: Me("label" & k).Caption = f.Cells(1, k): Next k
End Sub

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

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

Listbox triée

ListBox triée

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  a = f.Range("a2:c" & f.[A65000].End(xlUp).Row)
  Call Tri(a, 1, LBound(a), UBound(a))
  Me.ListBox1.list = a
End Sub

Sub Tri(a, ColTri, gauc, droi) ' 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 k = LBound(a, 2) To UBound(a, 2)
        temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
      Next k
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call Tri(a, ColTri, g, droi)
  If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub

Listbox avec sélection triée

ListBox avec Sélection triée

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  a = f.Range("a2:c" & f.[A65000].End(xlUp).Row)
  Dim b(), c()
  j = 0
  Me.ListBox1.ColumnCount = 2
  Me.ListBox1.ColumnWidths = "45;100"
  For i = LBound(a) To UBound(a)
    If a(i, 1) = "Oui" Then
      j = j + 1
      ReDim Preserve b(1 To 2, 1 To j)
      b(1, j) = a(i, 2)
      b(2, j) = a(i, 3)
    End If
  Next i
  If j > 1 Then
     c = Application.Transpose(b)
     Call Tri(c(), 1, LBound(c, 1), UBound(c, 1))
     Me.ListBox1.list = c
   Else
      Me.ListBox1.AddItem b(1, 1)
      Me.ListBox1.list(0, 1) = b(2, 1)
   End If
End Sub

Sub Tri(a(), ColTri, gauc, droi) ' 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 k = LBound(a, 2) To UBound(a, 2)
          temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
        Next k
        g = g + 1: d = d - 1
      End If
    Loop While g <= d
    If g < droi Then Call Tri(a, ColTri, g, droi)
    If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub

Private Sub CommandTriNom_Click()
  Dim a()
  a = Me.ListBox1.list
  Call Tri(a(), 1, LBound(a, 1), UBound(a, 1))
  Me.ListBox1.list = a
End Sub

Recherche avec choix premières lettres

Liste Intuitive

Nom de champ
Liste =DECALER(BD!$A$2;;;NBVAL(BD!$A:$A)-1;2)

Private Sub UserForm_Initialize()
  Me.ListBox1.List = [liste].Value
End Sub

Private Sub TextBox1_Change()
  Me.ListBox1.Clear
  i = 0
  For Each c In Application.Index([liste], , 1)
    If UCase(c) Like UCase(Me.TextBox1) & "*" Then
       Me.ListBox1.AddItem
       Me.ListBox1.List(i, 0) = c.Value
       Me.ListBox1.List(i, 1) = c.Offset(, 1).Value
       i = i + 1
    End If
  Next c
End Sub

Private Sub ListBox1_Click()
  ActiveCell = Me.ListBox1
  ActiveCell.Offset(, 1) = Me.ListBox1.Column(1)
  Unload Me
End Sub

ListBox multi colonnes trié

ListBoxMultiColTrie

Private Sub UserForm_Initialize()
  With Sheets("BD")
    Me.ListBox1.List = .Range("A2:C" & .[A65000].End(xlUp).Row).Value
  End With
  a = Me.ListBox1.List
  Call tri(a, LBound(a), UBound(a), 0)
  Me.ListBox1.List = a
End Sub

Sub tri(a, gauc, droi, colTri) ' Quick sort
  NbCol = UBound(a, 2) - LBound(a, 2) + 1 ' nb de colonnes
  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, colTri)
  If gauc < d Then Call tri(a, gauc, d, colTri)
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

ListBox Multi-colonnes trié Multi-critères

Ci dessous, nous trions par Nom+ville ou Ville+Nom

TriListBoxMultiCritères
TriListBoxMultiCritèresNomPrénom

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

Private Sub LTriNom_Click()
  Dim clé() As String, index() As Long
  Dim a(), b()
  a = Me.ListBox1.List
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  ReDim clé(LBound(a) To UBound(a, 1))
  ReDim index(LBound(a) To UBound(a, 1))
  For i = LBound(a) To UBound(a, 1)
     clé(i) = a(i, 0) & a(i, 1): index(i) = i
  Next i
  Call Tri(clé(), index(), LBound(a), UBound(clé))
  For lig = LBound(clé) To UBound(clé)
     For col = LBound(a, 2) To UBound(a, 2): b(lig, col) = a(index(lig), col): Next col
  Next lig
  Me.ListBox1.List = b
  Me.LTriNom.ForeColor = vbRed
  Me.LTriVille.ForeColor = vbBlack
  Me.LCP.ForeColor = vbBlack
End Sub

Sub Tri(clé() As String, index() As Long, gauc, droi) ' Quick sort
  ref = clé((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While clé(g) < ref: g = g + 1: Loop
    Do While ref < clé(d): d = d - 1: Loop
    If g <= d Then
      temp = clé(g): clé(g) = clé(d): clé(d) = temp
      temp = index(g): index(g) = index(d): index(d) = temp
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call Tri(clé, index, g, droi)
  If gauc < d Then Call Tri(clé, index, 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

Au fur et à mesure de la frappe du texte cherché, les lignes qui contiennent le texte cherché sont affichées dans le formulaire.
Le nombre de colonnes affichées dans le formulaire s'adapte au nombe de colonnes de la BD.

FormIntuitifMultiColonnes
FormIntuitifMultiColonnesBis
Liste Intuitive Plusieurs mots désordre formulaire TextBox ListBox
Recherche Adhérent Find
Liste Intuitive Plusieurs mots désordre formulaire TextBox ListBox Multi-colonnes
Liste Intuitive Plusieurs mots désordre formulaire CombotBox Multi-colonnes

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
  Set plage = f.[A1].CurrentRegion
  Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1)
  Me.ListBox1.List = plage.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 plage = plage.Offset(1).Resize(plage.Rows.Count - 1)
  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

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

Pour une recherche sur des mots entiers

Set c = plage.Find(Me.TextBox1, , , xlWhole)

Pour une recherche dans la première colonne seulement

Remplacer

Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1)

Par

Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1, 1)

Pour récupérer le résultat dans une feuille

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

Pour récupérer la ligne sélectionnée dans une feuille

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

Validation de la recherche avec bouton OK

Pour une recherche plus rapide, la validation de la recherche se fait avec un bouton ok et non plus à la saisie de chaque caractère. En outre, le remplissage de la ListBox se fait plus rapidement avec une tableau temp()

FormIntuitifMultiColonnesBis

Private Sub B_ok_Click()
  Dim temp()
  Me.ListBox1.Clear
  i = 0
  Set plage = f.[A1].CurrentRegion
  Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1)
  'Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1, 1) ' 1ere colonne
  Set c = plage.Find(Me.TextBox1, , , xlPart)
  If Not c Is Nothing Then
     premier = c.Address
     Do
        i = i + 1
        ReDim Preserve temp(1 To nbcol, 1 To i)
        lig = c.Row - plage.Row + 1
        For col = 1 To nbcol
          temp(col, i) = plage.Cells(lig, col)
        Next col
        Set c = plage.FindNext(c)
     Loop While Not c Is Nothing And c.Address <> premier
     If i > 1 Then      
       Me.ListBox1.List = Application.Transpose(temp)
     Else
       Me.ListBox1.AddItem
       For col = 1 To nbcol
         Me.ListBox1.List(i - 1, col - 1) = temp(col, i)
       Next col
     End If
   End If
End Sub

Recherche d'un mot dans une BD

La recherche se fait dans toutes les colonnes de la BD. Le filtrage est obtenu en masquant les lignes. On peut placer le curseur sur une ligne en cliquant dans la ListBox.

Recherche mot dans une BD

Private Sub B_ok_Click()
  Application.ScreenUpdating = False
  Set f = ActiveSheet
  Me.ListBox1.Clear
  Set plage = f.[A5].CurrentRegion
  plage.Interior.ColorIndex = 2
  Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1)
  Set c = plage.Find(Me.TextBox1, , , xlPart)
  If Not c Is Nothing Then
     i = 0
     premier = c.Address
     Do
       Me.ListBox1.AddItem
       Me.ListBox1.List(i, 0) = c.Value
       Me.ListBox1.List(i, 1) = c.Row
       c.Interior.ColorIndex = 3
       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()
   Application.ScreenUpdating = False
   Set f = ActiveSheet
   Set plage = f.[A5].CurrentRegion
   plage.Rows.Hidden = False
End Sub

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

Private Sub B_filtre_Click()
   Application.ScreenUpdating = False
   Set f = ActiveSheet
   Set plage = f.[A5].CurrentRegion
   plage.Offset(1).Rows.Hidden = True
   n = Me.ListBox1.ListCount
   For i = 0 To n - 1
      ligne = Me.ListBox1.List(i, 1)
      ActiveSheet.Rows(ligne).Hidden = False
   Next i
End Sub

Private Sub B_copie_Click()
  Set f = ActiveSheet
  Sheets("Result").Cells.ClearContents
  Set plage = f.[A5].CurrentRegion
  plage.SpecialCells(xlCellTypeVisible).Copy Sheets("Result").[A1]
End Sub

Recherche intuitive multi-colonnes de plusieurs mots séparés par le caractère espace

- plusieurs mots dans le désordre
- et dans toutes les colonnes de la BD

Liste Intuitive Plusieurs mots désordre formulaire TextBox ListBox Multi-colonnes
Liste Intuitive Plusieurs mots désordre formulaire TextBox ListBox Multi-colonnes Cave vins
Liste Intuitive Plusieurs mots désordre formulaire CombotBox Multi-colonnes
Recherche_Intuitive Multi_Mots_Multi_Colonnes
Recherche_Intuitive Multi_Mots_Zone de texte
Recherche_Intuitive Multi_Mots_Zone de texte Modif Ajout Sup

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

Colonne partiellement masquée

Le nom du groupe n'apparaît qu'une seule fois dans la première colonne.

ListBoxGroup

Private Sub UserForm_Initialize()
  i = 0
  For Each c In Range("a2:a" & [A65000].End(xlUp).Row)
    If c.Offset(-1, 1) <> c.Offset(, 1) Then tmp = c.Offset(, 1) Else tmp = ""
    Me.ListBox2.AddItem
    Me.ListBox2.List(i, 0) = tmp
    Me.ListBox2.List(i, 1) = c
    i = i + 1
  Next c
End Sub

Autre version

Les noms de groupe ne peuvent pas être sélectionnés

Private Sub UserForm_Initialize()
  ListBox1.MultiSelect = fmMultiSelectMulti
  For Each c In Range("a2:a" & [A65000].End(xlUp).Row)
    If c.Offset(-1, 1) <> c.Offset(, 1) Then
       Me.ListBox1.AddItem
       Me.ListBox1.List(i, 0) = ""
       Me.ListBox1.List(i, 1) = "x"
       i = i + 1
       Me.ListBox1.AddItem
       Me.ListBox1.List(i, 0) = c.Offset(, 1)
       Me.ListBox1.List(i, 1) = "x"
       i = i + 1
       Me.ListBox1.AddItem
       Me.ListBox1.List(i, 0) = ""
      Me.ListBox1.List(i, 1) = "x"
    Else
      Me.ListBox1.AddItem c
    End If
    i = i + 1
  Next c
End Sub

Private Sub ListBox1_change()
  p = Me.ListBox1.ListIndex
  If p >= 0 Then
     If Me.ListBox1.List(p, 1) = "x" Then Me.ListBox1.Selected(p) = False
  End If
End Sub

Tri de ListBox

Liste Triée Croissant_Décroissant
Form Tri ListBox Alpha ou Num
Form Tri ListBox Multi Colonnnes Croissant/Décroissant
Form Tri ListBox Multi-colonnes Alpha ou Num multi-critères

Liste des fichiers d'un répertoire

Liste fichiers répertoire

Private Sub UserForm_Initialize()
  If Me.répertoire = "" Then Me.répertoire = ThisWorkbook.Path
  Dim Tbl()
  nf = Dir(Me.répertoire & "\*.*")
  n = 0
  Do While nf <> ""
    n = n + 1
    ReDim Preserve Tbl(1 To 2, 1 To n)
    Tbl(1, n) = nf
    Tbl(2, n) = Format(FileDateTime(Me.répertoire & "\" & nf), "yyyy/mm/dd hh:mm")
    nf = Dir
  Loop
  If n > 0 Then
    If n > 1 Then
       Me.ListBox1.List = Application.Transpose(Tbl)
    Else
       Dim aa(1 To 1, 1 To 2)
       aa(1, 1) = Tbl(1, 1): aa(1, 2) = Tbl(2, 1)
       Me.ListBox1.List = aa
    End If
  End If
  Me.TextBox1 = Me.ListBox1.ListCount & " Fichiers"
  Me.TypeFich.List = Array("*.*", "*.xls", "*.jpg", "*.mdb", "*.txt")
  Me.TypeFich.ListIndex = 0
End Sub

Private Sub B_triNom_Click()
  Dim a()
  a = Me.ListBox1.List ' 0 To n,0 To x
  Call Quick(a(), LBound(a), UBound(a), 0, True)
  Me.ListBox1.List = a
  Me.ListBox1.ListIndex = 0
End Sub

Private Sub B_triDate_Click()
  Dim a()
  a = Me.ListBox1.List ' 0 To n,0 To x
  Call Quick(a(), LBound(a), UBound(a), 1, True)
  Me.ListBox1.List = a
  Me.ListBox1.ListIndex = Me.ListBox1.ListCount - 1
End Sub

Private Sub b_tridateDesc_Click()
  Dim a()
  a = Me.ListBox1.List ' 0 To n,0 To x
  Call Quick(a(), LBound(a), UBound(a), 1, False)
  Me.ListBox1.List = a
  Me.ListBox1.ListIndex = 0
End Sub

Private Sub TypeFich_Change()
  Dim Tbl()
  nf = Dir(Me.TypeFich)
  n = 0
  Do While nf <> ""
     n = n + 1
     ReDim Preserve Tbl(1 To 2, 1 To n)
     Tbl(1, n) = nf
     Tbl(2, n) = Format(FileDateTime(nf), "yyyy/mm/dd hh:mm")
     nf = Dir
  Loop
  If n > 0 Then
     If n > 1 Then
        Me.ListBox1.List = Application.Transpose(Tbl)
     Else
        Dim aa(1 To 1, 1 To 2)
        aa(1, 1) = Tbl(1, 1): aa(1, 2) = Tbl(2, 1)
        Me.ListBox1.List = aa
     End If
  End If
  Me.TextBox1 = Me.ListBox1.ListCount & " Fichiers"
End Sub

Private Sub B_répertoire_Click()
  If Val(Application.Version) >= 10 Then
    With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = CurDir()
    .Show
    If .SelectedItems.Count > 0 Then
      Me.répertoire = .SelectedItems(1)
    Else
      Me.répertoire = ""
    End If
    ChDir Me.répertoire
    UserForm_Initialize
   End With
  Else
    DossierChoisi = VoirDossier("Choisir le dossier")
    If DossierChoisi <> "" Then
        Me.répertoire = DossierChoisi
    End If
    ChDir Me.répertoire
    UserForm_Initialize
  End If
End Sub

Sub Quick(a(), gauc, droi, col, ordre) ' Quick sort
  ref = a((gauc + droi) \ 2, col)
  g = gauc: d = droi
  Do
    Do While IIf(ordre, a(g, col) < ref, a(g, col) > ref): g = g + 1: Loop
    Do While IIf(ordre, ref < a(d, col), ref > a(d, col)): d = d - 1: Loop
    If g <= d Then
      For i = LBound(a, 2) To UBound(a, 2)
         temp = a(g, i): a(g, i) = a(d, i): a(d, i) = temp
      Next i
      g = g + 1: d = d - 1
   End If
  Loop While g <= d
  If g < droi Then Call Quick(a, g, droi, col, ordre)
  If gauc < d Then Call Quick(a, gauc, d, col, ordre)
End Sub

 

 

 



Exemples

2 colonnes
2colonnes Tableau
Multi Colonnes
TriListBoxMultiColonnes rapide