Formulaire liste multi-colonnes

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

Autre exemple

ComboBox Multi-colonnes

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set Rng = f.Range("A2:C" & f.[A65000].End(xlUp).Row)
  Me.ComboBox1.ColumnCount = 3
  Me.ComboBox1.ColumnWidths = "50;50;40"
  Me.ComboBox1.List = Rng.Value
End Sub

Private Sub ComboBox1_Click()
  Me.TextBox1 = Me.ComboBox1
  Me.TextBox2 = Me.ComboBox1.Column(1)
  Me.TextBox3 = Me.ComboBox1.Column(2)
End Sub

La propriété TextColumn du comboBox définit la colonne (1,2,...) qui est récupérée dans le comboBox après le choix.

ComboBox Multi-colonnes

Ajout ListBox

Ajout ListBox
Ajout ListBox plus 10 colonnes

Dim f
Private Sub UserForm_Initialize()
Set f = Sheets("bd")
Me.NoCommande = f.[A65000].End(xlUp) + 1
End Sub

Private Sub B_ok_Click()
  If Not IsNumeric(Me.TextBox3) Then MsgBox "Num!": Me.TextBox3.SetFocus: Exit Sub
  If Not IsDate(Me.TextBox4) Then MsgBox "Date!": Me.TextBox4.SetFocus: Exit Sub
  Me.ListBox1.AddItem Me.NoCommande
  n = Me.ListBox1.ListCount - 1
  Me.ListBox1.List(n, 1) = Me.Nom
  Me.ListBox1.List(n, 2) = Me.TextBox1
  Me.ListBox1.List(n, 3) = Me.TextBox2
  Me.ListBox1.List(n, 4) = CDbl(Me.TextBox3)
  Me.ListBox1.List(n, 5) = Me.TextBox4
  For i = 1 To 4: Me("textbox" & i) = "": Next i
  Me.TextBox1.SetFocus
End Sub

Private Sub b_sup_Click()
ligne = Me.ListBox1.ListIndex
If ligne <> -1 Then Me.ListBox1.RemoveItem ligne
End Sub

Private Sub B_transfert_Click()
  ligne = f.[A65000].End(xlUp).Row + 1
  n = Me.ListBox1.ListCount
  If n > 0 Then
    Tbl = Me.ListBox1.List
    For i = 0 To n - 1: Tbl(i, 4) = CDate(Tbl(i, 4)): Next i
    f.Cells(ligne, "a").Resize(n, 6) = Tbl
    Me.Nom = "": Me.Nom.SetFocus
    Me.ListBox1.Clear
  End If
End Sub

Si la colonne montant(<0 ou >0)est éclatée en 2 colonnes (recettes et dépenses)

Ajout ListBox 2

Private Sub B_transfert_Click()
  ligne = f.[A65000].End(xlUp).Row + 1
  n = Me.ListBox1.ListCount
  If n > 0 Then
    Tbl = Me.ListBox1.List
    For i = 0 To n - 1: Tbl(i, 5) = CDate(Tbl(i, 5)): Next i
    '-- ajout d'une colonne dans TBl()
    Ncol = UBound(Tbl, 2) + 1
    Dim Tbl2(): ReDim Tbl2(0 To n - 1, 0 To Ncol + 1) ' nouveau tableau
    For i = 0 To n - 1
      For k = 0 To 3: Tbl2(i, k) = Tbl(i, k): Next k ' transfert 4 premières colonnes
      If Tbl(i, 4) < 0 Then Tbl2(i, 4) = -Tbl(i, 4) Else Tbl2(i, 5) = Tbl(i, 4) ' transfert 1 col dans 2 cols
      For k = 5 To Ncol - 1: Tbl2(i, k + 1) = Tbl(i, k): Next k ' transfert dernières colonnes
    Next i
    '----- transfert tableur
    f.Cells(ligne, "a").Resize(n, Ncol + 1) = Tbl2
    Me.Nom = "": Me.Nom.SetFocus
    Me.ListBox1.Clear
  End If
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 Rng = Range("a:a")
Set c = Rng.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 = Rng.FindNext(c)
     i = i + 1
   Loop While Not c Is Nothing And c.Address <> premier
End If
End Sub

Pour récupérer la ligne choisie dans le ListBox

Private Sub oK2_Click()
  If Me.ListBox1.ListIndex <> -1 Then
    [G2] = Me.ListBox1
    [H2] = Me.ListBox1.Column(1)
    [I2] = Me.ListBox1.Column(2)
  End If
End Sub

Autre méthode

Private Sub B_go_Click()
  Dim Tbl()
  Set Rng = Range("a:a")
  Set c = Rng.Find(Me.TextBox1.Value, LookIn:=xlValues)
  If Not c Is Nothing Then
    premier = c.Address
    n = 0
    Do
      n = n + 1: ReDim Preserve Tbl(1 To 3, 1 To n)
      Tbl(1, n) = c.Value: Tbl(2, n) = c.Offset(0, 1).Value: Tbl(3, n) = c.Offset(0, 2).Value
      Set c = Rng.FindNext(c)
    Loop While Not c Is Nothing And c.Address <> premier
  End If
  Me.ListBox1.Column = Tbl
End Sub

Private Sub B_ok_Click()
ligne = Me.ListBox1.ListIndex + 1
If ligne <> -1 Then [F2].Resize(, 3) = Application.Index(Me.ListBox1.List, ligne)
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 avec éléments de couleurs différentes

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
ComboBox 1 colonne couleur simule
ComboBox images
ListBox images

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

Simulation ComboBox avec éléments de couleurs différentes

ComboBox 1 colonne couleur simule

ListBox avec photos

Simulation ListBox avec Photo
Survol photo

Alimentation d'un listbox par des champs discontinus

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

Avec Rowsource

Avec RowSource, toutes les lignes de la BD sont affichées. On ne peut pas sélectionner seulement certaines lignes.

ListBox champs discontinus RowSource

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set Rng = f.Range("A2:G" & f.[A65000].End(xlUp).Row)
  Me.ListBox1.ColumnHeads = True
  Me.ListBox1.ColumnCount = 7
  Me.ListBox1.ColumnWidths = "50;50;0;40;0;0;40"
  Me.ListBox1.RowSource = Rng.Address
End Sub

Avec List/Column

Méthode 1

ListBox champs discontinus 1

On met à 0 la largeur des colonnes à masquer.

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set Rng = f.Range("A2:G" & f.[A65000].End(xlUp).Row)
  Me.ListBox1.ColumnCount = 7
  Me.ListBox1.ColumnWidths = "50;50;0;40;0;0;60"
  Me.ListBox1.List = Rng.Value
End Sub

Méthode 2

La méthode plus courte à programmer

ListBox champs discontinus 2

Dim ColVisu(), LargeurCol(), Rng
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")                          ' Adapter
  Set Rng = f.Range("A2:G" & f.[A65000].End(xlUp).Row) ' Adapter
  ColVisu = Array(1, 2, 4, 7)                 ' Adapter
  LargeurCol = Array(60, 50, 50, 100) ' Adapter
  Me.ListBox1.ColumnCount = UBound(ColVisu) + 1
  Me.ListBox1.ColumnWidths = Join(LargeurCol, ";")
  Me.ListBox1.List = Application.Index(Rng, Evaluate("Row(1:" & Rng.Rows.Count & ")"), ColVisu)
  EnteteListBox
End Sub

Méthode 3

Conversion d'un champ Union en Array()

ListBox champs Union

Private Sub UserForm_Initialize()
  Set Rng = Range("A2:A10,C2:C10,E2:E10")   ' Champ Union
  Tbl = Tableau(Rng)
  Me.ListBox1.ColumnCount = UBound(Tbl, 2)
  Me.ListBox1.List = Tbl
End Sub

Function Tableau(Rng)
  NbLig = Rng.Rows.Count: NbCol = Rng.Areas.Count
  Dim Tbl(): ReDim Tbl(1 To NbLig, 1 To NbCol)
  For i = 1 To NbCol
    For j = 1 To NbLig: Tbl(j, i) = Rng.Areas(i)(j): Next j
  Next i
  Tableau = Tbl
End Function

Méthode 4

La méthode la plus rapide.

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

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  TblBD = f.Range("A2:G" & f.[A65000].End(xlUp).Row).Value
  Dim TblRes: ReDim TblRes(1 To UBound(TblBD), 1 To 4)
  col = 0
  For Each k In Array(1, 2, 4, 7) ' colonnes à récupérer
    col = col + 1
    For i = 1 To UBound(TblBD): TblRes(i, col) = TblBD(i, k): Next i
  Next k
  Me.ListBox1.List = TblRes
End Sub

Autres exemples

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

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

Récupération de colonnes discontinues d'un ListBox dans onglet

Récupération colonnes discontinues ListBox

Sur cet exemple, on récupère les colonnes 1,3,6 du ListBox dans les colonnes J,K,L

Private Sub B_recup2_Click()
  Application.ScreenUpdating = False
  Set f = Sheets("Result")
  n = ListBox1.ListCount
  Tbl = Me.ListBox1.List
  f.[J2].Resize(n, 3) = Application.Index(Tbl, Evaluate("Row(1:" & n & ")"), Array(1, 3, 6))
End Sub

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
Filtre TextBox ListBox Colonnes discontinues entete

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 un TextBox

Filtre TextBox ListBox feuille intermédiaire

Cette méthode nécessite une feuille intermédiaire et ne calcule pas les largeurs de colonne.

Option Compare Text
Dim f, RngBD, ColRecherche
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  ColRecherche = 4
  Set RngBD = f.[A1].CurrentRegion
  Me.ListBox1.ColumnCount = f.[A1].CurrentRegion.Columns.Count
  Me.ListBox1.ColumnWidths = "80;50;50;60;75;50" ' à adapter
  Me.ListBox1.ColumnHeads = True
  TextBox1_Change
End Sub

Private Sub TextBox1_Change()
  Set f2 = Sheets("filtre")
  f2.Cells.Clear
  f2.[Z1] = RngBD.Cells(1, ColRecherche): f2.[Z2] = Me.TextBox1 & "*"
  f.[A1].CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f2.[Z1:Z2], _
    CopyToRange:=f2.[A1], Unique:=False
  If f2.[A1].CurrentRegion.Rows.Count > 1 Then
    Set RngFiltre = f2.[A1].CurrentRegion.Offset(1).Resize(f2.[A1].CurrentRegion.Rows.Count - 1)
    Me.ListBox1.RowSource = RngFiltre.Address(External:=True)
  End If
End Sub

Filtre TextBox ListBox
Filtre TextBox ListBox 2
Filtre TextBox ListBox Colonnes discontinues entete
Filtre TextBox ListBox Colonnes discontinues entete Tri
Filtre TextBox ListBox multi-Sélection
Filtre TextBox ListBox Recherche multi-colonnes

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

Filtre TextBox ListBox 1
Filtre TextBox ListBox 2
Filtre TextBox ListBox Choix colonne recherche

Dim f, TblBD()
Option Compare Text

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  TblBD = f.Range("A2:F" & f.[A65000].End(xlUp).Row).Value
  Me.ListBox1.List = TblBD
  Me.ListBox1.ColumnCount = 6
  Me.ListBox1.ColumnWidths = "100;50;50;50;50;50"
End Sub

Private Sub TextBoxMotClé_Change()
  ColRecherche = 1
  clé = "*" & Me.TextBoxMotClé & "*": n = 0
  Dim Tbl()
  For i = 1 To UBound(TblBD)
    If TblBD(i, ColRecherche) Like clé Then
       n = n + 1: ReDim Preserve Tbl(1 To UBound(TblBD, 2), 1 To n)
       For k = 1 To UBound(TblBD, 2): Tbl(k, n) = TblBD(i, k): Next k
    End If
  Next i
  If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear
End Sub

Filtre ListBox multi-colonnes par un TextBox avec colonnes discontinues

Filtre TextBox ListBox Colonnes discontinues
Filtre TextBox ListBox Colonnes discontinues entete

Filtre ListBox multi-colonnes par un ComboBox

Cette méthode nécessite une feuille intermédiaire et ne calcule pas les largeurs de colonne.

Filtre ComboBox ListBox feuille intermédiaire

Option Compare Text
Dim f, RngBD, ColRecherche
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set d = CreateObject("Scripting.Dictionary")
  Set RngBD = f.[A1].CurrentRegion.Offset(1)
  ColRecherche = 2      ' adapter
  d("*") = ""
  For i = 1 To RngBD.Rows.Count
    clé = RngBD.Cells(i, ColRecherche): d(clé) = ""
  Next i
  Me.ComboBox1.List = d.keys ' liste des professions sans doublons
  Me.ListBox1.ColumnCount = RngBD.Columns.Count
  Me.ListBox1.ColumnWidths = "80;50;50;60;80;50" ' à adapter
  Me.ListBox1.ColumnHeads = True
  ComboBox1_click
End Sub

Private Sub ComboBox1_click()
  Set f2 = Sheets("filtre")
  f2.Cells.Clear
  f2.[Z1] = RngBD.Offset(-1).Cells(1, ColRecherche): f2.[Z2] = Me.ComboBox1
  f.[A1].CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f2.[Z1:Z2], _
   CopyToRange:=f2.[A1], Unique:=False
  Set RngFiltre = f2.[A1].CurrentRegion.Offset(1).Resize(f2.[A1].CurrentRegion.Rows.Count - 1)
  Me.ListBox1.RowSource = RngFiltre.Address(External:=True)
  Me.TextBox1 = Format(Application.Sum(Application.Index(RngFiltre, , 6)), "0000.00")
End Sub

Filtre ComboBox ListBox
Filtre ComboBox ListBox bis
Filtre ComboBox ListBox Hyperlien
Filtre ComboBox ListBox 2
Filtre ComboBox ListBox 3
Filtre ComboBox ListBox Choix colonne recherche
Filtre ComboBox ListBox Choix colonne recherche 2
Filtre surlignage ListBox
Filtre combobox ListBox colonnes discontinues tableau

Autre version

S'adapte automatiquement à la BD sous forme de tableau nommé Tableau1.
Permet l'Ajout,Modif et suppression.

Filtre ComboBox ListBox Choix colonne recherche fiche

Filtre cases à cocher

Filtre une BD avec plusieurs mots-clés

-Fonctionne pour tout type de BD
-Calcule tous les mots clés de la BD
-Choix intuitif des mots clés dans des comboboxs
-Affichage des résultats dans une ListBox

Filtre ensemble de mots-clés form OU ComboBox

Ici l'opérateur saisit des mots-clés séparés par le caractère espace

Filtre ensemble de mots-clés form OU TextBox
Filtre ensemble de mots-clés form ET ComboBox
Filtre ensemble de mots-clés form ET TextBox

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 entre 2 Dates
ListBox entre 2 dates calendrier MicroSoft
ListBox entre 2 dates calendrier autonome

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

Filtre TextBox ListBox

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)

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 BD avec choix de la colonne de recherche 2
Recherche intuitive BD avec choix de la colonne de recherche
Recherche intuitive BD avec choix de la colonne de recherche modif
Recherche intuitive BD avec choix de la colonne de recherche modif sans vides

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 avec saut de ligne dans ListBox

ListBox avec Saut de ligne
ListBox avec Saut de ligne Groupes
ListBox avec Saut de ligne Groupes 2

Filtre dans comboBox & recherche intuitive sur TextBox

Choix ComBox & recherche intuitive sur nom

Autre exemple

Filtre par marque de véhicules avec Modification,Création, Suppression.

Filtre clé marque
Filtre clé marque 2

Filtre 3 clés

Option Compare Text
Dim f, TblBD, ColVisu(), Ncol
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  ColVisu = Array(1, 3, 4, 6, 7, 8) ' Colonnes à visualiser (adapter)
  Ncol = UBound(ColVisu) + 1
  TblBD = f.Range("A2:M" & f.[A65000].End(xlUp).Row) ' adapter
  Me.Listbox1.ColumnCount = UBound(ColVisu) + 1
  EnTeteListBox
  Me.OptionButton4=True
End Sub

Private Sub OptionButton1_Click()
  etat = Me.OptionButton1.Caption
  affiche etat
End Sub

Private Sub OptionButton2_Click()
  etat = Me.OptionButton2.Caption
  affiche etat
End Sub

Private Sub OptionButton3_Click()
  etat = Me.OptionButton3.Caption
  affiche etat
End Sub

Private Sub OptionButton4_Click()
  etat = "*": affiche etat
End Sub

Sub affiche(etat)
  n = 0
  For i = 1 To UBound(TblBD)
    If TblBD(i, 3) Like etat Then
      n = n + 1: ReDim Preserve Tbl(1 To Ncol, 1 To n)
      c = 0
      For Each K In ColVisu: c = c + 1: Tbl(c, n) = TblBD(i, K): Next K
    End If
  Next i
  Me.Listbox1.Column = Tbl
End Sub

Filtre ListBox multi-colonnes avec ListBox options Multi-sélection

Filtre ListBox Multi-colonnes multi-clés avec ListBox
Filtre ListBox Multi-colonnes multi-clés avec ListBox2

Option Compare Text
Dim TblBD(), NbCol, NomTableau
Private Sub UserForm_Initialize()
  TblBD = [Tableau1].Value
  NbCol = UBound(TblBD, 2)
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To UBound(TblBD): d(TblBD(i, 3)) = "": Next i
  temp = d.keys
  Tri temp, LBound(temp), UBound(temp)
  Me.ListBox1.List = temp
  Me.ListBox2.ColumnCount = NbCol
  Me.ListBox2.ColumnWidths = "50;45;50;50;55;70;45"
End Sub

Private Sub ListBox1_Change()
  Dim clé()
  For i = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(i) = True Then
      n = n + 1: ReDim Preserve clé(1 To n)
      clé(n) = Me.ListBox1.List(i)
    End If
  Next i
  If n > 0 Then
    Tbl = FiltreArrayCléColRécup(TblBD, clé, 3, Array(1, 2, 3, 4, 5, 6, 7))
    For i = LBound(Tbl) To UBound(Tbl): Tbl(i, 6) = Format(Tbl(i, 6), "0000.00"): Next i
    Me.ListBox2.List = Tbl
  Else
    Me.ListBox2.Clear
  End If
End Sub

Filtre comboBox

Filtre ComboBox
Filtre ComboBox 2

Option Compare Text
Dim f
Private Sub UserForm_Initialize()
  Set d = CreateObject("scripting.dictionary")
  Set f = Sheets("test")
  TblBD = f.Range("A2:E" & f.[E65000].End(xlUp).Row).Value
  For i = 1 To UBound(TblBD)
   If TblBD(i, 4) = "non" Then d(TblBD(i, 1)) = ""
  Next i
  Me.ComboBox1.List = d.keys
End Sub

Private Sub ComboBox1_click()
  Set result = f.[A:A].Find(what:=Me.ComboBox1)
  Me.TextBox1 = result.Offset(, 1)
  Me.TextBox2 = result.Offset(, 2)
  Me.TextBox3 = result.Offset(, 4)
End Sub

Utilisation des tableaux dynamiques

Les avantages de la présentation Tableau:
-Pas besoin de spécifier la feuille
-Le tableau s'grandit automatiquement en hauteur & largeur)
-Si on ajoute une ligne, les formules sont recopiées

La référence aux différents éléments d'un tableau dynamique est relative au tableau:
-Un tableau dynamique peut donc être déplacé sans qu'il soit nécessaire de modifier la programmation des numéros de colonne.

NbCol = [Tableau1].Columns.Count                    ' Nombre colonnes de la BD
TblBD = [Tableau1].Resize(, NbCol + 1).Value     ' BD dans Array
Me.ComboTri.List = Application.Transpose([Tableau1].Offset(-1).Resize(1)) ' Titres BD
[Tableau1].Rows(ligne).Delete                            ' Suppression ligne
[Tableau1].Item(ligne, Colonne) = tmp                ' Ecriture dans la BD en ligne,colonne
n = [Tableau1].Rows.Count                                ' Nombre de lignes de la BD
TitreColonne2 = [Tableau1].Offset(-1).Item(1,2) ' Entête de la colonne 2
TblNoms = [Tableau1[nom]]                               ' Colonne des noms dans TblNoms(,)
temp=[Tableau1[nom]].Item(1)                          ' Premier nom dans temp
Tbl = [tableau1[nom]]                                        ' Colonne nom dans Array Tbl()
Tbl = [tableau1].Columns(2)                               ' Colonne 2 dans Array Tbl()
TblTout = Range("Tableau1[#all]")                      ' Tableau avec entete
TblEntete = Range("Tableau1[#all]").Rows(1)       ' en-tête tableau
MsgBox TblEntete(1, 2)                                       ' Entête 2e colonne
TblEntete = Range("Tableau1").ListObject.HeaderRowRange
MsgBox TblEntete(1, 2)
Tbl3col = Range("Tableau1[[nom]:[ville]]")             ' 3 Colonnes adjacentes
NomFeuille = Range("Tableau1").Parent.Name         ' nom de la feuille hôte
Set Rng = Range("Tableau1[nom], Tableau1[ville]") ' champs discontinus
MsgBox Rng.Areas(2)(1)                                        ' 1ere ville

Syntaxe ListObject

TblBD =Sheets("bd").ListObjects(1).Range.Resize(, 3)             ' BD dans un Array
n = Sheets("bd").ListObjects(1).DataBodyRange.Rows.Count   ' Nombre de lignes
Tbl = Sheets("bd").ListObjects(1).HeaderRowRange                ' Titres
Sheets("bd").ListObjects(1).DataBodyRange.Item(1, 1) = "Dupont"
Sheets("bd").ListObjects(1).ListRows.Add (1)       ' Ajout d'une ligne en position 1
Sheets("bd").ListObjects(1).ListRows.Add            ' Ajout d'une ligne en fin
Sheets("bd").ListObjects(1).DataBodyRange.Rows(2).Delete   ' Suppression ligne 2
Tbl =Sheets("bd").ListObjects(1).DataBodyRange.Columns(1) ' Colonne 1 dans un Array
f2.ListObjects(1).DataBodyRange.Delete              ' Suppression des données

Récupération d'un ListBox dans un Tableau

Set f2 = Sheets("résultatTableau")
f2.Cells.Clear
Tbl = Me.ListBox1.List
f2.[A2].Resize(UBound(Tbl) + 1, UBound(Tbl, 2) + 1) = Tbl
TblTitre = Sheets("bd").ListObjects(1).HeaderRowRange ' Titres
For c = 1 To UBound(TblTitre, 2)
f2.Cells(1, c) = TblTitre(1, c)
Next c
f2.ListObjects.Add(xlSrcRange, f2.Range("A1").Resize(UBound(Tbl) + 2, UBound(TblTitre, 2)), , xlYes).Name = "Tableau2"
f2.ListObjects("Tableau2").TableStyle = "TableStyleMedium15"
f2.Cells.EntireColumn.AutoFit

Autre méthode en ajoutant les enregistrements un par un, permettant ainsi de choisir les colonnes de la ListBox.

Set f2 = Sheets("RésultatTableau")
f2.Cells.Clear
'--- création tableau
TblTitre = Sheets("bd").ListObjects(1).HeaderRowRange ' on prend les titres d'un autre tableau
For c = 1 To UBound(TblTitre, 2)
  f2.Cells(1, c) = TblTitre(1, c)
Next c
f2.ListObjects.Add(xlSrcRange, f2.Range("A1").Resize(, UBound(TblTitre, 2)), , xlYes).Name = "Tableau2"
f2.ListObjects("Tableau2").TableStyle = "TableStyleMedium15"
'--- Transfert
Tbl = Me.ListBox1.List
For i = LBound(Tbl) To UBound(Tbl)
   f2.ListObjects(1).ListRows.Add ' Ajout d'une ligne en fin
   For c = 0 To UBound(Tbl, 2)
     f2.ListObjects(1).DataBodyRange.Item(i + 1, c + 1) = Tbl(i, c)
   Next c
Next i
f2.Cells.EntireColumn.AutoFit

Liste des tableaux d'un classeur

For s = 1 To Sheets.Count
  For Each n In Sheets(s).ListObjects
    MsgBox n.Name
  Next n
Next s

Cases d'option dynamiques avec ListBox

Cases d'options avec ListBox
Cases d'options avec ListBox Choix Col Visu

La propriété ListStyle du ListBox est positionnée à ListStyleOption.
Sur l'exemple, le programme s'adapte automatiquement à la BD.

Pour Excel<2007
Set f = Sheets("bd") ' Pour Excel<Excel 2007
Set Rng = f.Range("A2:G" & f.[A65000].End(xlUp).Row) ' à adapter
NomTableau = "Tableau1"
ActiveWorkbook.Names.Add Name:=NomTableau, RefersTo:=Rng

Dim TblBD(), NbCol
Private Sub UserForm_Initialize()
  NbCol = [Tableau1].Columns.Count
  TblBD = [Tableau1].Resize(, NbCol).Value ' Array: + rapide
  Me.ListBox1.List = TblBD
  EnteteListBox1
  '--- construction des cases d'options villes
  Set d = CreateObject("scripting.dictionary")
  For Each c In [Tableau1[Ville]]: d(c.Value) = "": Next c
  d("*") = ""
  temp = d.keys
  Tri temp, LBound(temp), UBound(temp)
  Me.ListBox2.List = temp ' Villes triées
End Sub

Private Sub ListBox2_Click()
  Dim TblDest()
  n = 0
  For i = 1 To UBound(TblBD)
     If TblBD(i, 3) Like Me.ListBox2 Then
       n = n + 1: ReDim Preserve TblDest(1 To UBound(TblBD, 2), 1 To n)
       For k = 1 To NbCol : TblDest(k, n) = TblBD(i, k): Next k
     End If
   Next i
   Me.ListBox1.Column = TblDest
End Sub

Autre écriture - sans TblBD() - mais moins rapide

Private Sub ListBox2_Click()
  Dim TblDest(): n = 0
  NlignesBD = [Tableau1].Rows.Count
  For Each c In [Tableau1[Ville]]
    If c Like Me.ListBox2 Then
      n = n + 1: ReDim Preserve TblDest(1 To NlignesBD, 1 To n)
      For k = 1 To NbCol: TblDest(k, n) = c: Next k
    End If
  Next c
  Me.ListBox1.Column = TblDest
End Sub

Sur l'exemple, le programme s'adapte automatiquement à la BD jusqu'à 24 colonnes. Au delà, ajouter TextBox25,TextBox26,..Label25,Label26,...
Les champs peuvent être positionnés manuellement sur le formulaire.

-Un combobox permet de choisir la colonne de recherche
-Un comboxox permet de choisir la colonne de tri du ListBox
-Des TextBoxs permettent de modifier la BD

-pour modifier manuellement l'écran de saisie, supprimer l'appel de LabelsTextBox

Filtre ListBox avec tableau dynamique
Filtre ListBox avec tableau dynamique Choix Col Visu

Pour Excel<2007
Set f = Sheets("bd") ' pour versions Excel <2007
Set Rng = f.Range("A2:V" & f.[A65000].End(xlUp).Row) ' pour versions Excel <2007
ActiveWorkbook.Names.Add Name:="Tableau1", RefersTo:=Rng 'pour versions Excel <2007

Autres exemples

Filtre multi-colonnes choix colonne filtre tableau dynamique
Filtre multi-colonnes choix colonne filtre tableau dynamique Intuitif
Form Filtre 6 ComboBoxs tableau dynamique
Form Filtre 6 ComboBoxs tableau dynamique multi-pages
Form Filtre 6 ComboBoxs tableau dynamique multi-pages2
Form Filtre 6 ComboBoxs tableau dynamique multi-pages Calculs
Form Filtre 6 ComboBoxs tableau dynamique Scroll Frame

BD Multi-tables avec tableaux dynamiques

BD Vetos Clients Animaux

Option Compare Text
Private Sub UserForm_Initialize()
  Me.enreg = Application.Max([animaux[id]]) + 1
  Me.Id = Application.Max([animaux[id]]) + 1
  Me.Recherche.List = [Animaux].Value
  Me.IdCli.List = [client].Value
  Me.IdVeto.List = [veto].Value
  Me.FamilleF.List = [Famille].Value
  Me.SexeF.List = [Sexe].Value
End Sub

Private Sub Recherche_Change()
  Me.enreg = Application.Match(Val(Me.Recherche), [animaux[id]], 0)
  Me.Id = Me.Recherche
  Me.Nom = [Animaux].Item(enreg, 2)
  Me.FamilleF = [Animaux].Item(enreg, 3)
  Me.RaceF = [Animaux].Item(enreg, 4)
  Me.SexeF = [Animaux].Item(enreg, 5)
  Me.IdCli = [Animaux].Item(enreg, 6)
  Me.IdVeto = [Animaux].Item(enreg, 7)
  Me.NomClient = Application.VLookup(Val(Me.IdCli), [client], 2, False)
  Me.NomVeto = Application.VLookup(Val(Me.IdVeto), [veto], 2, False)
End Sub

Private Sub FamilleF_Change()
  Race = [Race].Value
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To UBound(Race)
    If Race(i, 1) = Me.FamilleF Then d(Race(i, 2)) = ""
  Next i
  Me.RaceF.List = d.keys
End Sub

Private Sub IdVeto_click()
Me.NomVeto = Application.VLookup(Val(Me.IdVeto), [veto], 2, False)
End Sub

Private Sub IdCli_Click()
Me.NomClient = Application.VLookup(Val(Me.IdCli), [client], 2, False)
End Sub

Private Sub B_valid_Click()
   enreg = Me.enreg
   [Animaux].Item(enreg, 1) = Val(Me.Id)
   [Animaux].Item(enreg, 2) = Me.Nom
   [Animaux].Item(enreg, 3) = Me.FamilleF
   [Animaux].Item(enreg, 4) = Me.RaceF
   [Animaux].Item(enreg, 5) = Me.SexeF
   [Animaux].Item(enreg, 6) = Val(Me.IdCli)
   [Animaux].Item(enreg, 7) = Val(Me.IdVeto)
End Sub

Private Sub B_sup_Click()
  If MsgBox("Etes vous sûr de supprimer " & Me.Nom & "?", vbYesNo) = vbYes Then
      [Animaux].Rows(Me.enreg).Delete
   End If
End Sub

Private Sub B_ajout_Click()
  raz
  Me.Id = Application.Max([animaux[id]]) + 1
  Me.enreg = Application.Max([animaux[id]]) + 1
End Sub

Sub raz()
  Me.Nom = ""
  Me.IdCli = ""
  Me.IdVeto = ""
  Me.FamilleF = ""
  Me.RaceF = ""
  Me.SexeF = ""
  Me.NomClient = ""
  Me.NomVeto = ""
End Sub

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 TextBox
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 avec choix de la colonne de filtre

Filtre multi-colonnes choix colonne filtre
Filtre multi-colonnes choix colonne filtre Tableau
Filtre multi-colonnes choix colonne filtre intuitif

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.

Private Sub UserForm_Initialize()
Set f = Sheets("bd")
Set Rng = f.Range("A2:V" & f.[A65000].End(xlUp).Row) ' à adapter
NomTableau = "Tableau1"
ActiveWorkbook.Names.Add Name:=NomTableau, RefersTo:=Rng

A partir d'Excel 2007, on peut utiliser la mise en forme Tableau

Les instructions:
Set Rng = f.Range("A2:V" & f.[A65000].End(xlUp).Row) ' à adapter
ActiveWorkbook.Names.Add Name:=NomTableau, RefersTo:=Rng
Ne sont plus nécessaires.

Filtre 1 à 6 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 6 comboboxs peuvent être définies.

Filtre multi-colonnes 6 comboboxs désordre
Filtre multi-colonnes 9 comboboxs désordre
Filtre multi-colonnes 9 comboboxs désordre textbox
Filtre Interventions

Filtre intersection d'ensembles

Filtre intersection d'ensembles
Filtre intersection d'ensembles Result
Filtre intersection d'ensembles col Visu
Filtre intersection d'ensembles stat

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
ListBox entre 2 dates calendrier
ListBox entre 2 dates calendrier MicroSoft

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

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

Entête simple

Ils ne peuvent afficher que des entêtes pour des ListBox issus de Ranges et pas d'Arrays.

Entête simple pour ListBox
Entête simple pour ListBox Tableau
Entête simple pour ListBox Tableur
Entête simple pour ListBox Tableur2
Entête pour ListBox Tableur3

Dim Rng, NbCol
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set Rng = f.Range("A2:E" & f.[A65000].End(xlUp).Row)
  NbCol = Rng.Columns.Count
  Me.ListBox1.RowSource = Rng.Address
  For c = 1 To NbCol
     tempcol = tempcol & Rng.Columns(c).Width * 1# & ";"
  Next c
  Me.ListBox1.ColumnHeads = True
  Me.ListBox1.ColumnCount = NbCol
  Me.ListBox1.ColumnWidths = tempcol
  LabelsTextBox
End Sub

Entete avec Labels

Cette méthode permet d'afficher des entêtes pour tous les ListBoxs (Additem, Arrays) et pas seulement les ListBoxs ayant comme source un Range.

ListBox en-têtes
Entête ListBox Textox recherche mot intuitif
ListBox en-têtes colonnes discontinues Tableau
Entête ListBox Textox colonnes discontinues
Entête ListBox Textox colonnes discontinues recherche intuitif
ListBox en-têtes Cave Vin

Dim Rng, NbCol
P rivate Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set Rng = f.Range("A2:D" & f.[A65000].End(xlUp).Row)
  NbCol = Rng.Columns.Count
  Me.ListBox1.ColumnCount = NbCol
  tblBD = Rng.Value
  For i = 1 To UBound(tblBD): tblBD(i, 4) = Format(tblBD(i, 4), "0000.00"): Next i
  Me.ListBox1.List = tblBD
  EnteteListBox
  PiedListBox
End Sub

Sub EnteteListBox()
  x = Me.ListBox1.Left + 8
  Y = Me.ListBox1.Top - 12
  For i = 1 To NbCol
    Set lab = Me.Controls.Add("Forms.Label.1")
    lab.Caption = Rng.Offset(-1).Cells(1, i)
    lab.Top = Y
    lab.Left = x
    x = x + Rng.Columns(i).Width * 1.1
    temp = temp & Rng.Columns(i).Width * 1.1 & ";"
  Next
  temp = Left(temp, Len(temp) - 1)
  Me.ListBox1.ColumnWidths = temp
End Sub

Sub PiedListBox()
  x = Me.ListBox1.Left + 8
  Y = Me.ListBox1.Top + Me.ListBox1.Height + 5
  For c = 1 To NbCol
    Set lab = Me.Controls.Add("Forms.Label.1")
    Tbl = Me.ListBox1.List
    Tbl2 = Application.Index(Tbl, , c)
    For i = 1 To UBound(Tbl2)
      If IsNumeric(Tbl2(i, 1)) Then Tbl2(i, 1) = CDbl(Tbl2(i, 1))
    Next i
    temp = Format(Application.Sum(Tbl2), "0.00")
    If temp <> 0 Then lab.Caption = temp: lab.BackColor = vbGreen
     lab.Top = Y
    tmp = Format(Application.Sum(Tbl2), "0.00")
    lab.Left = x + Rng.Columns(c).Width * 1# - Len(tmp) * 4
    lab.Height = 12
    lab.Width = Rng.Columns(c).Width * 1#
    x = x + Rng.Columns(c).Width * 1
  Next c
End Sub

Pied listbox

Pied Listbox

Private Sub ComboBox1_click()
  ColRecherche = 1
  clé = Me.ComboBox1: n = 0
  Dim Tbl()
  For i = 1 To UBound(TblBD)
    If TblBD(i, ColRecherche) Like clé Then
       n = n + 1: ReDim Preserve Tbl(1 To UBound(TblBD, 2), 1 To n)
       For k = 1 To UBound(TblBD, 2): Tbl(k, n) = TblBD(i, k): Next k
    End If
  Next i
  If n > 0 Then
     Me.ListBox1.Column = Tbl
     Me.TextBox1 = Application.Sum(Application.Index(Me.ListBox1.List, , 5))
     Me.TextBox2 = Application.Sum(Application.Index(Me.ListBox1.List, , 6))
  Else
   Me.ListBox1.Clear
  End If
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 & TextBox Intuitif

ListBox Mult-iColonnesTextBox Intuitif.xls

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.

ListBox 12
Transfert plus 10 colonnes

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

Autre façon de procéder

Si on redimensionne l'Array a() au fur et à mesure des ajouts de ligne, il faut faire attention à Transpose:
S'il n'y a qu'une seule ligne. Transpose transforme l'Array 2D a() en un tableau 1 D.
ListBox1.Column=a() au lieu de ListBox1.List=Application.Transpose(a) évite ce problème.

Private Sub ComboBox1_Click()
  Dim a()
  ligne = 0
  For i = 1 To bd.Rows.Count
    If bd.Cells(i, 1) = Me.ComboBox1 Then
       ligne = ligne + 1
       ReDim Preserve a(1 To bd.Columns.Count, 1 To ligne)   ' on travaille sur un tableau transposé
       For k = 1 To bd.Columns.Count: a(k, ligne) = bd.Cells(i, k): Next k
    End If
  Next i
  Me.ListBox1.Column = a    ' Il n'y a pas de problème s'il n'y a qu'une ligne
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 dans un textbox

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

Autre exemple avec modification, ajout, suppression

Annuaire Intuitif

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

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

Sommaire onglets Affiche/Cache les feuilles

Sommaire Onglets Affiche/Cache

Dim témoin
Private Sub Worksheet_Activate()
  témoin = True
  ListBox1.Clear
  For s = 2 To Sheets.Count
     ListBox1.AddItem Sheets(s).Name
      ListBox1.Selected(s - 2) = Sheets(s).Visible
  Next s
  témoin = False
End Sub

Private Sub ListBox1_change()
  If Not témoin Then
     For i = 0 To Me.ListBox1.ListCount - 1
       temp = ListBox1.List(i)
       Sheets(temp).Visible = Me.ListBox1.Selected(i)
     Next i
   End If
End Sub

Groupe options multiples dynamiques avec ListBox

Permet de choisir une ou plusieurs options.

Groupe Options Multiples
Groupe Options Multiples 2

Option Compare Text
Dim TblBD()
Private Sub UserForm_Initialize()
  TblBD = [client].Value ' pour rapidité
  TriMultiCol TblBD, 1, UBound(TblBD), 3
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To [client].Rows.Count
     tmp = TblBD(i, 3): d(tmp) = ""
  Next i
  Me.OptionsGroupe.MultiSelect = fmMultiSelectMulti
  Me.OptionsGroupe.ListStyle = 1 'frmliststyleoption
  Tbl = d.keys
  Tri Tbl, LBound(Tbl), UBound(Tbl)
   Me.OptionsGroupe.List = Tbl
   Me.ListBox1.ColumnCount = [client].Columns.Count + 1
   Me.ListBox1.ColumnWidths = "60;50;30;50;100;70;70;50"
   Me.ListBox1.List = TblBD
End Sub

Private Sub OptionsGroupe_change()
  Set dchoisis1 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.OptionsGroupe.ListCount - 1
    If Me.OptionsGroupe.Selected(i) Then dchoisis1(Me.OptionsGroupe.List(i, 0)) = ""
  Next i
  Dim Tbl2(): n = 0: Ncol = UBound(TblBD, 2)
  For i = 1 To UBound(TblBD)
    tmp = TblBD(i, 3)
    If dchoisis1.exists(tmp) Then
      n = n + 1: ReDim Preserve Tbl2(1 To Ncol, 1 To n)
      For k = 1 To Ncol: Tbl2(k, n) = TblBD(i, k): Next k
    End If
  Next i
  If n > 0 Then Me.ListBox1.Column = Tbl2 Else Me.ListBox1.Clear
End Sub

Groupe Options Multiples 3

Sur cette version, il y a 2 à 3 colonnes de recherche paramétrées.

Groupe Options Multiples 4 critères
Groupe Options Multiples 4 critères bis
Groupe Options Multiples 5 critères

Boutons suivant /précédent dans un ListBox

Suivant Précédent ListBox

Private Sub B_suivant_Click()
  If Me.ListBox1.ListIndex < Me.ListBox1.ListCount - 1 Then
     Me.ListBox1.ListIndex = Me.ListBox1.ListIndex + 1
  End If
End Sub

Private Sub b_précédent_Click()
  If Me.ListBox1.ListIndex > 0 Then
     Me.ListBox1.ListIndex = Me.ListBox1.ListIndex - 1
  End If
End Sub

Lisibilité ListBox

Private Sub UserForm_Initialize()
Me.ListBox2.ColumnCount = [Tableau1].Columns.Count
Me.ListBox2.ColumnWidths = "50;45;50;50"
Me.ListBox2.List = [Tableau1].Value
Me.ListBox2.MultiSelect = fmMultiSelectMulti
For i = 0 To Me.ListBox2.ListCount - 1 Step 2
Me.ListBox2.Selected(i) = True
Next i
End Sub

Private Sub ListBox2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.ListBox2.MultiSelect = fmMultiSelectSingle
End Sub