Formulaire liste multi-colonnes

Accueil

Liste plusieurs colonnes
Liste plusieurs colonnes avec tableau
Liste plusieurs colonnes avec AddItem
Alimentation d'un Listbox par List/Column
Simulation ListBox couleur
Alimentation ListBox avec des colonnes discontinues
ListBox conditionnelle multi-colonnes
Fltre ListBox sur 1 condition (date)
Filtre ListBox par un TextBox
Filtre ListBox par une clé
Filtre avec 2 ou 3 critères
Filtre 1 à 5 critères choisis dans le désordre
Affichage d'une zone filtrée dans une ListBox
Tri ListBox multi-colonnes
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
ListBox avec plus de 10 colonnes
Recherche numéro téléphone
ListBox avec sélection triée
Recherche sur les premières lettres
Multi colonnes sans doublons trié
Listes triées multi-colonnes et multi critères
Recherche multi-critère
Recherche intuitive multi-colonnes
Recherche intuitive multi-colonnes multi-mots
Tri ListBox multi-Colonnes 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 Rowsource

Si une ListBox est alimentée par RowSource et si ColumnsHead est positionné à True, on peut récupérer les titres de la BD avec ;

Private Sub B_recup_Click()
   Tbl = Application.Index(Range(Me.ListBox1.RowSource).Offset(-1).Value, 1)
   MsgBox Tbl(1) & " " & Tbl(2)
End Sub

Alimentation d'une ListBox avec Additem

Liste MultiColonnes.xls
Liste MultiColonnes Commence Contient.xls
Liste MultiColonnes ComboBox Intuitif.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/Column

List est la méthode la plus rapide. On utilise Column pour un Array transposé.

ListBox Multi-Colonnes

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

Version trié

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  bd = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value ' version trié
  Tri bd, LBound(bd), UBound(bd), 1
  ListBox1.List = bd
End Sub

Extraire la ligne sélectionnée d'un ListBox & la somme d'une colonne

ListBox extraction Ligne Colonne

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Me.ListBox1.List = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
  Me.TextBox1 = Application.Sum(Application.Index(Me.ListBox1.List, , 3)) ' colonne 3
End Sub

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

Simulation listbox couleur

Nous simulons une ListBox couleur à 2 colonnes avec des labels et un ScrollBar.

ListBox 2 colonnes couleur simule
ListBox 2 colonnes couleur simule 2
ListBox 1 colonne couleur simule

Dim début, n
Dim Lbl(1 To 5) As New ClasseLabel
Private Sub UserForm_Initialize()
  n = 5: début = 1
  For b = 1 To n: Set Lbl(b).GrLabel = Me("Label" & b): Next b
  Me.ScrollBar1.Min = début
  Me.ScrollBar1.Max = [liste].Count - n + 1
  Affiche
End Sub

Sub Affiche()
  For i = 1 To n
    Me("label" & i).Caption = Range("liste").Cells(i + début - 1, 1)
    Me("label" & i).BackColor = Range("liste").Cells(i + début - 1, 1).Interior.Color
    '-- 2e colonne
    Me("label" & i + n).Caption = Range("liste").Cells(i + début - 1, 1).Offset(, 1)
    Me("label" & i + n).BackColor = Range("liste").Cells(i + début - 1, 1).Interior.Color
  Next i
End Sub

Private Sub ScrollBar1_Change()
  début = ScrollBar1
  Affiche
End Sub

Module de classe

Public WithEvents GrLabel As Msforms.Label
Private Sub GrLabel_click()
  p = Val(Mid(GrLabel.Name, 6))
  For i = 1 To 5: UserForm1("label" & i).BorderStyle = 0: Next i
  UserForm1("label" & p).BorderStyle = 1
  UserForm1.TextBox1 = GrLabel.Caption
End Sub

Alimentation d'un listbox par des champs discontinus

Pour la ListBox, on prend les colonnes A,B,D,G

ListBox champs discontinus
ListBox champs discontinus Largeur Colonnes
ListBox Champs Discontinus Entête
ListBox Champs Discontinus Entête police
Cascade ListBox champs discontinus
ListBox champs discontinus sans doublons trié

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Tbl1 = f.Range("A2:G" & f.[A65000].End(xlUp).Row).Value
  Dim Tbl2: ReDim Tbl2(1 To UBound(Tbl1), 1 To 5)
  j = 0
  For Each k In Array(1, 2, 4, 7)
     j = j + 1
     For i = 1 To UBound(Tbl1): Tbl2(i, j) = Tbl1(i, k): Next i
  Next k
  '--- colonne dates à convertir parce que toutes les dates ne sont pas au format date
  col = 4
  For i = 1 To UBound(Tbl1): Tbl2(i, col) = CDate(Tbl1(i, 7)): Next i
  '---
  Me.ListBox1.List = Tbl2
End Sub

Autres méthodes

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

ListBox multi-colonnes conditionnel avec Column

Pour 10.000 lignes, on obtient un temps de 0,07 sec (contre 2,5 sec avec Additem)

ListBox conditionnel multi-colonnes

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  bd = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  ville = "Paris"
  n = 0
  Dim TblDest()
  For i = 1 To UBound(bd)
     If bd(i, 3) = ville Then
       n = n + 1: ReDim Preserve TblDest(1 To UBound(bd, 2), 1 To n)
       For k = 1 To UBound(bd, 2): TblDest(k, n) = bd(i, k): Next k
     End If
  Next i
  Me.ListBox1.ColumnCount = 4
  Me.ListBox1.ColumnWidths = "40;30;30;50"
  Me.ListBox1.Column = TblDest
End Sub

Filtre ListBox multi-colonnes par une date

-Affiche dans un ListBox les lignes inférieures à la date du jour
-Sélectionne la ligne choisie dans la BD

Filtre ListBox Date

Filtre ListBox multi-colonnes par un TextBox avec choix de la colonne de recherche

Filtre TextBox ListBox

ListBox visualisé par blocs

ListBox visualisé par blocs

Filtre ListBox multi-colonnes par une clé

Pour filtrer une ville (2.000 éléments/10.000), on obtient un temps de réponse de 0,1 sec (1,6 sec pour Additem)

Filtre ListBox Clé
Filtre ListBox Clé2
Filtre ListBox Clé colonnes non contigues
Filtre ListBox Clé colonnes non contigues Scroll
Filtre ListBox Clé colonnes non contigues Modif Ajout Sup
Filtre ListBox Clé colonnes non contigues Scroll Modif
Filtre ListBox Clé boutons d'options

Dim f, bd
Option Compare Text
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set d = CreateObject("Scripting.Dictionary")
  bd = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  'Tri bd, LBound(bd), UBound(bd), 1 ' version tri
  Me.ListBox1.List = bd
  For i = LBound(bd) To UBound(bd)
     d(bd(i, 3)) = ""
  Next i
  Me.ComboBox1.List = d.keys    ' liste des villes sans doublons
  Me.ListBox1.ColumnCount = 4
  Me.ListBox1.ColumnWidths = "40;30;50;30"
End Sub

Private Sub ComboBox1_click()
  ville = Me.ComboBox1: n = 0
  Dim Tbl()
  For i = 1 To UBound(bd)
     If bd(i, 3) = ville Then
        n = n + 1: ReDim Preserve Tbl(1 To UBound(bd, 2), 1 To n)
        For k = 1 To UBound(bd, 2): Tbl(k, n) = bd(i, k): Next k
     End If
   Next i
   Me.ListBox1.Column = Tbl
End Sub

Version trié par nom

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set d = CreateObject("Scripting.Dictionary")
  bd = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  Tri bd, LBound(bd), UBound(bd), 1
  Me.ListBox1.List = bd
  For i = LBound(bd) To UBound(bd)
     d(bd(i, 3)) = ""
  Next i
  Me.ComboBox1.List = d.keys
End Sub

En utilisant une fonction FiltreMultiColTransp(array, Clé, colClé), le code ComboBox1_click() devient:

Filtre Array Multi-colonnes
Recherche BD avec choix de la colonne de recherche
Recherche intuitive BD avec choix de la colonne de recherche

Private Sub ComboBox1_click()
  Clé = Me.ComboBox1: colClé = 6
  b = FiltreMultiColTransp(bd, Clé, colClé)
  If Not IsEmpty(b) Then Me.ListBox1.Column = b
End Sub

Function FiltreMultiColTransp(Tbl, clé, colClé)
  Ncol = UBound(Tbl, 2)
  Dim b(): n = 0
  For i = LBound(Tbl) To UBound(Tbl)
    If clé = Tbl(i, colClé) Then
       n = n + 1: ReDim Preserve b(1 To Ncol, 1 To n)
       For k = 1 To Ncol: b(k, n) = Tbl(i, k): Next k
    End If
  Next i
  If n > 0 Then FiltreMultiColTransp = b
End Function

Sur cette version (FiltreLignesColonnes(array, Clé, colClé,ColonnesRésultat), on peut choisir les lignes et les colonnes.

Filtre Array Multi-colonnes Lignes colonnes

-Sur l'exemple, on filtre l'Array bd pour la ville de Paris en colonne 6 et on récupère les colonnes 1,2,6,7

b = FiltreLignesColonnesTransp(bd,"Paris", 6, Array(1, 2, 6, 7))

-Pour le critère de sélection,on peut spécifier "". On récupère ainsi toutes les lignes et seulement les colonnes spécifiées.

b = FiltreLignesColonnesTransp(bd,"", 6, Array(1, 2, 6, 7)) ' toutes les lignes

-Si on ne spécifie pas de colonnes, toutes les colonnes sont choisies.

b = FiltreLignesColonnesTransp(bd,"Paris", 6) ' toutes les colonnes

Filtre en cascade avec 3 critères

Ce pprogramme est paramétré.:

-Le nombre de colonnes de la BD peut être modifié.
-Les colonnes à afficher et l'odre peuvent être définis.
-Les colonnes des 3 combobox peuvent être définis.

Filtre multi-colonnes 3 conditions Choix colonnes 3
Filtre multi-colonnes 2 conditions
Filtre multi-colonnes 2 conditions Choix colonnes
Filtre multi-colonnes 3 conditions
Filtre multi-colonnes 3 conditions Choix colonnes
Filtre multi-colonnes 3 conditions Choix colonnes 2

Choix d'une colonne variable à afficher dans un listBox 3 colonnes

Choix d'une colonne variable dans un ListBox
Choix d'une classe

Filtre 1 à 5 critères choisis dans le désordre

Chaque combobox peut être utilisé seul ou combiné avec les autres. Les choix peuvent se faire dans un ordre quelconque comme dans un filtre automatique.

Ce programme est paramétré:

-Le nombre de colonnes de la BD peut être modifié.
-Les colonnes à afficher et l'ordre peuvent être définis.
-Les colonnes des 5 comboboxs peuvent être définies.

Filtre multi-colonnes 5 comboboxs désordre
Filtre Interventions

Filtre sur une année

Filtre année
Filtre année & ville
Filtre année plusieurs
Filtre année plusieurs ville
Filtre ListBox 2 dates

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set d = CreateObject("Scripting.Dictionary")
  bd = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  Tri bd, LBound(bd), UBound(bd), 4 ' version tri
  Me.ListBox1.List = bd
  For i = LBound(bd) To UBound(bd)
      d(Year(bd(i, 4))) = ""
  Next i
  Me.ComboBox1.List = d.keys
  Me.ListBox1.ColumnCount = 4
  Me.ListBox1.ColumnWidths = "50;30;50;30"
End Sub

Private Sub ComboBox1_click()
  an = Val(Me.ComboBox1): n = 0
  Dim Tbl()
  For i = 1 To UBound(bd)
     If Year(bd(i, 4)) = an Then
        n = n + 1: ReDim Preserve Tbl(1 To UBound(bd, 2), 1 To n)
        For k = 1 To UBound(bd, 2): Tbl(k, n) = bd(i, k): Next k
     End If
  Next i
  If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear
End Sub

Filtre année trimestre

Compter un mot dans une colonne d'une ListBox

Pour compter le nombre de fois où le mot Annulé apparaît dans la colonne 5:

Me.Label4.Caption = UBound(Filter(Application.Transpose(Application.Index(ListBox1.List, , 5)), "Annulé")) + 1

Affiche une zone filtrée dans un ListBox

Affiche zone filtrée ListBox

Tri d'un listbox multi-colonnes

Sur cet exemple , le ListBox est trié par nom.

ListBoxMultiColTrie

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Tbl = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
  Tri Tbl, LBound(Tbl), UBound(Tbl), 1
  Me.ListBox1.List = Tbl
End Sub

Sub Tri(a, gauc, droi, 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 = 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

Autre exemple

Sur cet exemple, le tri se fait par compte ou par libellé.

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

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

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

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

Autre exemple

-On peut choisir la colonne de tri dans un ComboBox.
-La seconde version est un ListBox issu de champs discontinus avec un champ date qui n'est pas au format date.

Tri ListBox Multi-colonnes
Tri ListBox Multi-colonnes champs discontinus

Option Compare Text
Dim f, RngTitre
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Me.ListBox1.List = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  Set RngTitre = f.Range("A1:D1")
  Me.ComboBox1.List = Application.Transpose(RngTitre.Value)
  Me.ComboBox1.ListIndex = -1
End Sub

Private Sub ComboBox1_click()
  Dim Tbl()
  Tbl = Me.ListBox1.List
  colTri = Application.Match(Me.ComboBox1, RngTitre, 0) - 1
  Tri Tbl(), LBound(Tbl), UBound(Tbl), colTri
  Me.ListBox1.List = Tbl
End Sub

Sub Tri(a(), gauc, droi, colTri) ' Quick sort
  colD = LBound(a, 2): ColF = UBound(a, 2)
  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 = colD To ColF
        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 Tri a, g, droi, colTri
  If gauc < d Then Tri a, gauc, d, colTri
End Sub

Private Sub B_recup_Click()
   Sheets("ReSult").[A2].Resize(Me.ListBox1.ListCount, 4).value2 = Me.ListBox1.List 'dates version<2007
End Sub

Tri d'une colonne numérique

Si une colonne contient des nombres sous forme de chaîne, il faut la convertir en numérique.

Tri ListBox Multi-colonnes colonne non numérique

Private Sub UserForm_Initialize()
  bd = [A2:D8]     ' la 4e colonne contient des nombres sous forme de chaîne
  For i = LBound(bd) To UBound(bd): bd(i, 4) = Val(bd(i, 4)): Next i
  TriMult bd, LBound(bd), UBound(bd), 4
  Me.ListBox1.List = bd
End Sub

ListBox Multi-colonnes trié Multi-critères avec index

Ci dessous, nous trions par Nom+ville ou Ville+Nom
L'index évite l'inversion de toutes les colonnes de l'Array multi-colonnes

TriListBoxMultiCritères
TriListBoxMultiCritèresNomPrénom

Private Sub UserForm_Initialize()
  Set f = Sheets("TriListBox")
  Me.ListBox1.List = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
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
  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

Listbox multi-colonnes trié avec SortedList

Ces tris sont moins rapides que Quick-sort

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

ou sans indexation

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), Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5))
  Next i
  Set AL = CreateObject("System.Collections.Arraylist")
  AL.AddRange SL.Values
  Me.ListBox1.Column = Application.Transpose(AL.toarray)
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 et Application.Transpose()

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

1- 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

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

3- Utilisation d'un Array() 0,15 s 10.000 lignes et 3.000 lignes vides

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Tbl1 = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  n = 0
  For i = 1 To UBound(Tbl1)
     If Tbl1(i, 1) <> "" Then n = n + 1
  Next i
  j = 0
  Dim Tbl2: ReDim Tbl2(1 To n, 1 To UBound(Tbl1, 2))
  For i = 1 To UBound(Tbl1)
     If Tbl1(i, 1) <> "" Then j = j + 1: For k = 1 To UBound(Tbl1, 2): Tbl2(j, k) = Tbl1(i, k): Next k
  Next i
  Me.ListBox1.List = Tbl2
End Sub

ou

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Tbl1 = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  n = 0: Dim Tbl2()
  For i = 1 To UBound(Tbl1)
    If Tbl1(i, 1) <> "" Then
      n = n + 1
      ReDim Preserve Tbl2(1 To UBound(Tbl1, 2), 1 To n)
      For k = 1 To UBound(Tbl1, 2): Tbl2(k, n) = Tbl1(i, k): Next k
    End If
  Next i
  Me.ListBox1.Column = Tbl2
End Sub

4- Avec Dictionary (0,4 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

5- Avec ArrayList (0,7 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
  Dim Tbl(): Tbl = Application.Transpose(al.toarray)
  n = UBound(Tbl, 2)
  If n > 0 Then
    ReDim Preserve Tbl(1 To 4, 1 To n + 1)
    Me.ListBox1.List = Application.Transpose(Tbl)
    Me.ListBox1.RemoveItem n
  End If
End Sub

6-Autre méthode (0,25 sec pour 10.000 lignes)

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  a = f.Range("A2:D" & f.[A65000].End(xlUp).Row).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 + 1)
  Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _
  Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
  Me.ListBox1.RemoveItem n
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

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
   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 avec sélection triée

La ListBox ne contient que les lignes de la BD ayant Oui dans la première colonne.

ListBox avec Sélection triée

Option Compare Text
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  bd = f.Range("a2:c" & f.[A65000].End(xlUp).Row).Value
  Me.ListBox1.ColumnCount = 2
  Me.ListBox1.ColumnWidths = "45;100"
  n = 0
  For i = 1 To UBound(bd)
    If bd(i, 1) = "Oui" Then n = n + 1
  Next i
  j = 0
  Dim Tbl: ReDim Tbl(1 To n, 1 To 2)
  For i = 1 To UBound(bd)
     If bd(i, 1) = "Oui" Then j = j + 1: For k = 1 To 2: Tbl(j, k) = bd(i, k + 1): Next k
  Next i
  Tri Tbl, 2, LBound(Tbl, 1), UBound(Tbl, 1)
  Me.ListBox1.List = Tbl
End Sub

Private Sub TriCompte_Click()
  a = Me.ListBox1.List
  Tri a, 0, LBound(a, 1), UBound(a, 1)
  Me.ListBox1.List = a
End Sub

Private Sub TriLibellé_Click()
  a = Me.ListBox1.List
  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

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

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.

Form Intuitif Multi Colonnes
Form Intuitif Multi Colonnes Bis
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 Modif Ajout Sup
Liste Intuitive Plusieurs mots désordre formulaire TextBox ListBox Multi-colonnes Modif Ajout Sup Histo
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
Liste Intuitive Plusieurs mots désordre formulaire CombotBox Multi-colonnes Choix Col
Liste Intuitive Plusieurs mots désordre formulaire CombotBox Multi-colonnes Choix Col2
Liste Intuitive Plusieurs mots désordre formulaire CombotBox Multi-colonnes Choix Col Scroll
Recherche_Intuitive Multi_Mots_Multi_Colonnes
Recherche_Intuitive Multi_Mots_Multi_Colonnes ListView
Recherche_Intuitive Multi_Mots_Zone de texte
Recherche_Intuitive Multi_Mots_Zone de texte Modif Ajout Sup
Recherche_Intuitive avec choix de la colonne de recherche

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
   Tri a(), LBound(a), UBound(a), 0
   Me.ListBox1.List = a
End Sub

Private Sub LTriVille_Click()
   Dim a()
   a = Me.ListBox1.List
   Tri a(), LBound(a), UBound(a), 1
   Me.ListBox1.List = a
End Sub

Private Sub LCP_Click()
    Dim a()
    a = Me.ListBox1.List
    Tri a(), LBound(a), UBound(a), 2
    Me.ListBox1.List = a
End Sub

Sub Tri(a(), gauc, droi, 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 =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 Tri a, g, droi, colTri
   If gauc < d Then Tri a, gauc, d, 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 Multi Colonnnes Croissant/Décroissant
Form Tri ListBox Multi-colonnes Alpha ou Num multi-critères avec index

Liste des fichiers d'un répertoire

Liste fichiers répertoire
Liste fichiers répertoire intuitif TextBox ListBox
Liste fichiers répertoire intuitif TextBox ListBox 2
Liste fichiers répertoire intuitif ComboBox

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