Menus en cascade

Accueil

Combobox en cascade 2 niveaux
Filtre ListBox par une clé
Combobox en cascade avec modification
Consultation/Modification avec doublons et recherche intuitive
Listbox cascade sans doublons
Choix d'un service
Liste en cascade ComboBox1/ListView
Liste intuitive plusieurs colonnes
Choix d'un service avec modification
Recherche par nom+prénom
Liste sans doublons avec 2 colonnes (nom+prénom)
Recherche BD avec choix de la colonne de recherche
Code Postal/Ville
Département/Code postal/Ville
Liste Cascade Pays
Alternative aux menus en cascade
Liste cascade triées
Listes en cascade 3 niveaux trié
Listes en cascade 4 niveaux trié
Listes en cascade 5 niveaux trié
Listes en cascade ordre quelconque(simulation filtre automatique)
Liste déroulante intuitive (saisie intuitive semi-automatique)
Recherche intuitive de plusieurs mots
Choix ligne de bus
Facture
Devis multi-lignes
Menus en cascade multi-sélection
Listes en cascade dans un classeur fermé avec ADO
ComboBox survol
ListBox survol avec Curseur
Choix successifs(listes différences)
WebBrowser dans un formulaire
Gestion de films avec recherche intuitive

ComboBox en cascade sans doublons

ComboBox2Niv
FormLSD

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("base")
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("B2:B" & f.[B65000].End(xlUp).Row) ' on explore la colonne de niveau 1
     MonDico(c.Value) = "" ' on ajoute l'élément de la famille au dictionnaire
  Next c
  Me.Famille.List = MonDico.keys
End Sub

Private Sub famille_click()
  Me.SousFamille.Clear
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("B2:B" & f.[B65000].End(xlUp).Row) ' on explore la colonne de niveau 1
     If c = Me.Famille Then MonDico(c.Offset(, 1).Value) = "" ' si famille alors on ajoute l'élément de la sous-famille au dictionnaire
  Next c
  Me.SousFamille.List = MonDico.keys
End Sub

Private Sub SousFamille_click()
  For Each c In f.Range("B2:B" & f.[B65000].End(xlUp).Row) ' on explore la colonne de niveau 1
    If c = Me.Famille And c.Offset(, 1) = Me.SousFamille Then Me.Code = c.Offset(, -1) ' si famille alors on ajoute l'élément de la sous-famille au dictionnaire
  Next c
End Sub

Autre version simplifiée

Dim f, dico
Private Sub UserForm_Initialize()
  Set f = Sheets("Base")
  Set dico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("B2:B" & f.[B65000].End(xlUp).Row)
     dico(c.Value) = IIf(dico.exists(c.Value), dico(c.Value) & "*" & c.Offset(, 1), c.Offset(, 1))
  Next c
  Me.Famille.List = dico.keys
End Sub

Private Sub Famille_click()
  Me.SousFamille.Clear
  Me.SousFamille.List = Split(dico(Me.Famille.Value), "*")
End Sub

Version avec tri (la base n'est pas triée)

ComboBox2NivTrié
ComboBox2Niv Mac
ComboBox2Niv Mac2
ComboBox2Niv FonctionSans Doublons Trié

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("base")
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("B2:B" & f.[B65000].End(xlUp).Row) ' on explore la colonne de niveau 1
     MonDico(c.Value) = "" ' on ajoute l'élément de la famille au dictionnaire
  Next c
  temp = MonDico.keys 'les clés du dico dans la table temp()
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.Famille.List = temp
End Sub

Private Sub famille_click()
   Me.SousFamille.Clear
   Set MonDico = CreateObject("Scripting.Dictionary")
   For Each c In f.Range("B2:B" & f.[B65000].End(xlUp).Row) ' on explore la colonne de niveau 1
     If c = Me.Famille Then MonDico(c.Offset(, 1).Value) = ""  ' si famille alors on ajoute l'élément de la sous-famille au dictionnaire
   Next c
   temp = MonDico.keys 'les clés du dico dans la table temp()
   Call Tri(temp, LBound(temp), UBound(temp))
   Me.SousFamille.List = temp
End Sub

Private Sub SousFamille_click()
  For Each c In f.Range("B2:B" & f.[B65000].End(xlUp).Row) ' on explore la colonne de niveau 1
    If c = Me.Famille And c.Offset(, 1) = Me.SousFamille Then Me.Code = c.Offset(, -1) ' si famille alors on ajoute l'élément de la sous-famille au dictionnaire
  Next c
End Sub

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

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,07 sec (2,5 sec pour Additem)

Filtre ListBox Clé

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

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

Sur cette version, on peut spécifier 1 ou 2 conditions

Function FiltreMultiCol2Transp(Tbl, colClé1, Clé1, ColResult, Optional colClé2, Optional Clé2, Optional ColTri)

Filtre Array Multi-colonnes avec 1 ou 2 conditions

Cascade avec ListBox

Cascade ComboBox 2 Niv ListBox

Recherche BD 2 critères + Ajout BD

Recherche BD 2 critères + Ajout BD

Formulaire cascade 2 niveaux avec comboBox 2 colonnes

FormCascadeComboBox2niveaux
TableurCascadeComboBox2niveaux

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BaseRéelle")
  Set dico = CreateObject("Scripting.Dictionary")
  Dim a()
  i = 0
  For Each c In f.Range("A3:A" & f.[A65000].End(xlUp).Row)
   If Not dico.exists(c.Value) Then
     Me.ComboBox1.AddItem c.Value
     Me.ComboBox1.List(i, 1) = c.Offset(, 1).Value
     i = i + 1
     dico(c.Value) = ""
   End If
  Next c
End Sub

Private Sub ComboBox1_Click()
  Me.ComboBox2.Clear
  i = 0
  For Each c In f.Range("A3:A" & f.[A65000].End(xlUp).Row)
    If c.Value = Me.ComboBox1 Then
      Me.ComboBox2.AddItem c.Offset(, 2).Value
      Me.ComboBox2.List(i, 1) = c.Offset(, 3).Value
      i = i + 1
    End If
 Next c
End Sub

Formulaire cascade 2 niveaux avec Consultation & modification & création

ComboBox2Niv Modification Création Trié Pc & Mac
ComboBox2Niv Modification Création Trié Pc & Mac Intuitif

Avec cette version, les noms des champs sont les titres de la BD
On peut donc ajouter des nouveaux champs dans la BD ou les déplacer sans modifier la programmation.

ComboBox2Niv Modification Création Général Trié Pc & Mac

Formulaire de consultation & modification avec doublons et saisie intuitive

-L'opérateur frappe les premières lettres du nom cherché.
-Les noms en doublon sont affichés dans une ListBox.
-Les libellés des champs du formulaire s'adaptent automatiquement aux titres de la BD. On peut déplacer des champs de la BD ou en ajouter sans modifier le programme.

Form Consultation/modification doublons intuitif

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

Doublons sur Nom+prénom avec 2 menus en cascade

S'il y a doublons sur Nom+prénom, on choisit la ville.

Recherche Nom + prénom doublons
CerfaCession

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

Doublons sur Nom+prénom avec un seul menu

On affiche la ville dans le ComboBox de recherche

Recherche Nom + prénom + ville avec no enreg

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Tblclé = Range("A2:D" & [A65000].End(xlUp).Row).Value             ' Nom+Prénom
  For i = 1 To UBound(Tblclé): Tblclé(i, 3) = f.Cells(i + 1, 7): Next i ' ville
  For i = 1 To UBound(Tblclé): Tblclé(i, 4) = i + 1: Next i                ' index
  Call Tri2Col(Tblclé, LBound(Tblclé), UBound(Tblclé))
  Me.ChoixNom.List = Tblclé
End Sub

Recherche dans une colonne de BD (choix de la colonne de recherche)

Sur cet exemple, on choisi la colonne de recherche dans un ComboBox.

Recherche BD
Recherche BD Intuitif
Recherche BD Photo

Listes en cascade sans doublons avec 2 colonnes (Nom+prénom)

FormCascadeSansDoublons2colonnesDict
Form Cascade Sans Doublons 2 colonnes Trié
Form Cascade Sans Doublons 2 colonnes Disjointes Trié
FormCascadeSansDoublons2colonnesMAC

Dim f, a()
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  a = f.Range("A2:D" & f.[B65000].End(xlUp).Row).Value
  Me.ComboBox1.List = f.Range("A2:D" & f.[B65000].End(xlUp).Row).Value
  Set d = CreateObject("Scripting.Dictionary")
  j = 0
  Do While j < Me.ComboBox1.ListCount
    tmp = ComboBox1.List(j, 0) & ListBox1.List(j, 1)
    If Not d.exists(tmp) Then
      d(tmp) = ""
      j = j + 1
    Else
     Me.ComboBox1.RemoveItem j
    End If
  Loop
End Sub

Menus en cascade avec cellules fusionnées

FormCascadeCellulesFusionnées
FormCascadeCellulesFusionnées2

ListBox en cascade sans doublons

FormCascadeSansDoublons

Dim dico
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set dico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
    dico(c.Value) = IIf(dico.exists(c.Value), dico(c.Value) & "*" & c.Offset(, 1), c.Offset(, 1))
  Next c
  Me.ListBox1.List = dico.keys
End Sub

Private Sub ListBox1_Click()
  Me.ListBox2.List = Split(dico(Me.ListBox1.Value), "*")
End Sub

Codes pour une classe

Cascade2Niveaux

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
     d.Item(c.Value) = ""
  Next c
  Me.ComboBox1.List = d.keys
End Sub

Private Sub ComboBox1_Change()
   Me.ComboBox2.Clear
   i = 0
   For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
     If c = Me.ComboBox1 Then
        Me.ComboBox2.AddItem c.Offset(0, 1)
        Me.ComboBox2.List(i, 1) = c.Offset(0, 2)
        i = i + 1
     End If
   Next c
   Me.ComboBox2.SetFocus
   SendKeys "{F4}"
End Sub

Private Sub ComboBox2_click()
    Me.adresse = Me.ComboBox2.Column(1)
End Sub

Animaux pour une personne

FormCascade

Private Sub UserForm_Initialize()
  Set mondico = CreateObject("Scripting.Dictionary")
  Set f = Sheets("BD")
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
    mondico.Item(c.Value) =""
  Next c
  Me.ComboBox1.List = mondico.keys
End Sub

Private Sub ComboBox1_Change()
  i = 0
  Me.ListBox1.Clear
  Set f = Sheets("BD")
  For Each c In f.Range("B2:B" & f.[B65000].End(xlUp).Row)
    If c.Offset(0, -1) = Me.ComboBox1 Then
       Me.ListBox1.AddItem
       Me.ListBox1.List(i, 0) = c.Value
       Me.ListBox1.List(i, 1) = c.Offset(0, 1).Value
       i = i + 1
    End If
  Next c
End Sub

Pays pour un continent

FormCascadeContinent

Private Sub UserForm_Initialize()
  Set f = Sheets("continent")
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
    mondico(c.Value) = ""
  Next c
  Me.ComboBox1.AddItem "*"
  For Each i In mondico.keys
     Me.ComboBox1.AddItem i
  Next
  Me.ComboBox1.ListIndex = 0
End Sub

Private Sub ComboBox1_Change()
  Set f = Sheets("continent")
  Me.ComboBox2.Clear
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
    If c = Me.ComboBox1 Or Me.ComboBox1 = "*" Then
       Me.ComboBox2.AddItem c.Offset(0, 1)
    End If
  Next c
  Me.ComboBox2.ListIndex = 0
End Sub

Version simplifiée

Private Sub UserForm_Initialize()
  Set f = Sheets("continent")
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
    If Not mondico.Exists(c.Value) Then mondico.Add c.Value, c.Value
  Next c
  Me.ComboBox1.List = mondico.items
  Me.ComboBox1.ListIndex = 0
End Sub

Autres exemples

ListeCascade 2 niveaux
ListeCascade 2 niveaux sans nom de champ
ListeCascade 2 niveaux Commentaire
ListeCascade 3 niveaux Commande
ListeCascade 3 niveaux Marque Modèle Couleur
ListeCascade 3 niveaux Marque Modèle Couleur3

Dim f
  Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Me.ListBox1.List = Application.Transpose(Range(f.[a1], f.[iv1].End(xlToLeft)))
End Sub

Private Sub ListBox1_Click()
  col = Me.ListBox1.ListIndex + 1
  i = 2
  Me.ListBox2.Clear
  Do While f.Cells(i, col) <> ""
    Me.ListBox2.AddItem f.Cells(i, col)
    i = i + 1
  Loop
End Sub

Autre exemple

ListeCascade 3 niveaux Marque Modèle Moteur

Autre exemple

FactureCascade
FactureCascade2

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set d1 = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
    If c <> "" Then d1(c.Value) = ""
  Next c
  Me.ComboBox1.List = d1.keys
End Sub

Private Sub ComboBox1_Click()
  Set début = f.[A:A].Find(Me.ComboBox1).Offset(1, 1)
  ligne = début.Row
  Do While f.Cells(ligne, "b") <> ""
    Me.ComboBox2.AddItem f.Cells(ligne, "b")
    ligne = ligne + 1
  Loop
End Sub

Private Sub ComboBox2_Click()
  Set prix = f.[B:B].Find(Me.ComboBox2).Offset(, 1)
  If Not prix Is Nothing Then Me.TextBox1 = prix
End Sub

Private Sub CommandButton1_Click()
  ActiveCell = Me.ComboBox2
  ActiveCell.Offset(, 1) = CDbl(Me.TextBox1)
  Unload Me
End Sub

Alternative aux menus en cascade

Sur cet exemple, au lieu de choisir la désignation dans un menu puis l'épaisseur dans autre menu, nous choisissons dans un seul menu la désignation et l'épaisseur.

Form Cascade
Form Cascade Devis Tableur

Private Sub UserForm_Initialize()
  Dim f
  Set f = Sheets("Tubes Ronds")
  ComboBox1.Clear
  i = 0
  Set design = f.Range("A2:A" & f.[a65000].End(xlUp).Row)
  For Each c In design
    If c <> "" Then tmp = c
    Me.ComboBox1.AddItem tmp
    Me.ComboBox1.List(i, 1) = c.Offset(, 1)
    Me.ComboBox1.List(i, 2) = c.Offset(, 3)
    Me.ComboBox1.List(i, 3) = c.Offset(, 2)
    Me.ComboBox1.List(i, 4) = c.Row
    i = i + 1
  Next
End Sub

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

Formulaire cascade normal

Form Cascade Normal

Dim f, Tbl()
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Tbl = f.Range("A2:D" & f.[D65000].End(xlUp).Row).Value
  For i = 2 To UBound(Tbl)
    If Tbl(i, 1) = "" Then Tbl(i, 1) = Tbl(i - 1, 1)
  Next i
  Set d1 = CreateObject("scripting.dictionary")
  For Each c In f.Range("A2:A" & f.[B65000].End(xlUp).Row)
    If c <> "" Then d1(c.Value) = ""
  Next
  Me.ComboBox1.List = d1.keys
End Sub

Private Sub ComboBox1_click()
  Me.ComboBox2.Clear
  For i = 1 To UBound(Tbl)
   If Me.ComboBox1 = Tbl(i, 1) Then Me.ComboBox2.AddItem Tbl(i, 2)
  Next i
End Sub

Private Sub ComboBox2_click()
  For i = 1 To UBound(Tbl)
    If Me.ComboBox1 = Tbl(i, 1) And CDbl(Me.ComboBox2) = Tbl(i, 2) Then
      Me.TextBox1 = Tbl(i, 3): Me.TextBox2 = Tbl(i, 4)
    End If
  Next i
End Sub

Autre exemple

Choix3Niv

Private Sub UserForm_Initialize()
  Me.ComboBox1.AddItem "Aluminium"
  Me.ComboBox1.AddItem "Cuivre"
  Me.ComboBox2.List = Application.Transpose([Type])
End Sub

Private Sub ComboBox1_Change()
   If Me.ComboBox2 <> "" Then niveau3
End Sub

Private Sub ComboBox2_Change()
   niveau3
End Sub

Private Sub ComboBox3_Change()
  Me.TextBox1 = Application.Index(Range(Me.ComboBox1), Me.ComboBox3.ListIndex + 1, 1)
End Sub

Sub niveau3()
   a = Application.Index(Range(Me.ComboBox1), , Application.Match(Me.ComboBox2, [Type], 0) + 1)
   Me.ComboBox3.List = a
   Me.ComboBox3.ListIndex = -1
   Me.TextBox1 = ""
End Sub

Menus en cascade ComboBox/ListView

CascadeComboListView

Dim Tbl(), f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set d = CreateObject("Scripting.Dictionary")
  Tbl = f.Range("A3:P" & f.[A65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl)
    If Tbl(i, 4) <> "" Then d(Tbl(i, 4)) = ""
  Next i
  temp = d.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
End Sub

Private Sub ComboBox1_Click()
  With Me.ListView1
    With .ColumnHeaders
     .Clear
     For k = 1 To 16
      .Add , , f.Cells(2, k), 55
     Next k
   End With
   ligne = 1
   .Gridlines = True
   .View = lvwReport
   .ListItems.Clear
   For lig = 1 To UBound(Tbl)
     If Tbl(lig, 4) = Me.ComboBox1 Then
       .ListItems.Add , , Tbl(lig, 1)
       For k = 2 To 16
         .ListItems(ligne).ListSubItems.Add , , Tbl(lig, k)
       Next k
       ligne = ligne + 1
     End If
   Next lig
  Me.TextBox1 = .ListItems.Count
 End With
End Sub

Liste intuitive sur une colonne

Liste intuitive

Private Sub UserForm_Initialize()
  Me.ListBox1.List = Range("clients").Resize(, 4).Value
End Sub

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

Private Sub ListBox1_Click()
  MsgBox Me.ListBox1
End Sub

Recherche intuitive dans toutes les colonnes

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

FormIntuitifMultiColonnes
FormIntuitifMultiColonnesBis
Recherche_Multi_Mots_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

Produits pour une date

Private Sub UserForm_Initialize()
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In [dates]
     If Not MonDico.Exists(c.Value) Then MonDico.Add c.Value, c.Value
  Next c
  Me.ComboBox1.List = MonDico.items
End Sub

Private Sub ComboBox1_Change()
  Me.ListBox1.Clear
  For Each c In [dates]
    If CDate(c) = CDate(Me.ComboBox1) And c.Offset(0, 1) <> "." Then
      Me.ListBox1.AddItem c.Offset(0, 1)
    End If
  Next c
End Sub

Choix d'un service

L'opérateur choisit d'abord le service puis la personne à afficher dans le formulaire.

FormService

Private Sub UserForm_Initialize()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range(Sheets("BD").[B2], Sheets("BD").[B65000].End(xlUp))
    If Not mondico.Exists(c.Value) Then mondico.Add c.Value, c.Value
  Next c
  Me.ComboBox1.AddItem "*"
  For Each i In mondico.items
    Me.ComboBox1.AddItem i
  Next
  Me.ComboBox1.ListIndex = 0
End Sub

Private Sub ComboBox1_Change()
  i = 0
  Me.ListBox1.Clear
  For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
    If c.Offset(0, 1) = Me.ComboBox1 Or Me.ComboBox1 = "*" Then
      Me.ListBox1.AddItem c
      i = i + 1
    End If
   Next c
   Me.ListBox1.ListIndex = 0
End Sub

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

Choix d'un service avec modification fiche

L'opérateur choisit d'abord le service puis la personne à afficher dans le formulaire

FormService2

Private Sub UserForm_Initialize()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range([B2], [B65000].End(xlUp))
    If Not mondico.Exists(c.Value) Then mondico.Add c.Value, c.Value
  Next c
  Me.ChoixService.AddItem "*"
  [A2:F1000].Sort key1:=[B2]
  For Each i In mondico.items
    Me.ChoixService.AddItem i
  Next
  Me.ChoixService.ListIndex = 0
  Me.service.List = mondico.items
  '-- Liste des noms
  [A2:F1000].Sort key1:=[A2]
  i = 2
    Do While Cells(i, 1) <> ""
      Me.ChoixNom.AddItem Cells(i, 1)
      i = i + 1
   Loop
  [A2].Select
   maj
End Sub

Private Sub ChoixService_Click()
  Me.ChoixNom.Clear
  If Me.ChoixService <> "*" Then
    For Each c In Range([A2], [A65000].End(xlUp))
       If c.Offset(0, 1) = Me.ChoixService Then Me.ChoixNom.AddItem c
    Next c
   Else
     For Each c In Range([A2], [A65000].End(xlUp))
       Me.ChoixNom.AddItem c
     Next c
   End If
End Sub

Sub maj()
   nom = ActiveCell.Value
   Me.service = ActiveCell.Offset(0, 1).Value
   Me.Salaire = ActiveCell.Offset(0, 2).Value
   Me.cyclisme = ActiveCell.Offset(0, 3).Value
   Me.tennis = ActiveCell.Offset(0, 4).Value
   '--
   For Each i In Me.transport.Controls
     If i.Caption = ActiveCell.Offset(0, 5) Then
        i.Value = True
     End If
   Next i
End Sub

Private Sub ChoixNom_Click()
[A:A].Find(ChoixNom, LookIn:=xlValues).Select
maj
End Sub

Private Sub b_validation_Click()
  If Me.nom = "" Then
    MsgBox "Saisir un nom!"
    Me.nom.SetFocus
    Exit Sub
  End If
  If Not IsNumeric(Me.Salaire) Then
    MsgBox "Saisir du num!"
    Me.Salaire.SetFocus
    Exit Sub
  End If
  If Salaire < 2000 Or Salaire > 20000 Then
    MsgBox "Salaire hors normes!"
    Me.Salaire.SetFocus
    Exit Sub
  End If
  '---- transfert base
  ActiveCell.Value = Application.Proper(Me.nom)
  ActiveCell.Offset(0, 1).Value = Me.service
  ActiveCell.Offset(0, 2).Value = CDbl(Me.Salaire)
  ActiveCell.Offset(0, 2).NumberFormat = "0.00 €"
  ActiveCell.Offset(0, 3).Value = Me.cyclisme
  ActiveCell.Offset(0, 4).Value = Me.tennis
  '--
  Resultat = ""
  For Each i In Me.transport.Controls
     If i.Value = True Then
       Resultat = i.Caption
     End If
  Next i
  ActiveCell.Offset(0, 5).Value = Resultat
  Me.nom.SetFocus
End Sub

Private Sub b_fin_Click()
Unload Me
End Sub

Private Sub B_ajout_Click()
Me.nom = ""
Me.service = ""
Me.Salaire = ""
Me.tennis = False
Me.cyclisme = False
Me.nom.SetFocus
[A65000].End(xlUp).Offset(1, 0).Select
End Sub

Code postal/Ville

L'opérateur choisit le code postal dans un premier menu puis la ville dans un second menu.

Form CodePostaux

Dim f, dico
Private Sub UserForm_Initialize()
  Set dico = CreateObject("Scripting.Dictionary")
  Set f = Sheets("CodesPostaux")
  Set code = f.Range("A2:B" & f.[A65000].End(xlUp).Row)
  temp = code
  For i = LBound(temp) To UBound(temp, 1)
    clé = CStr(temp(i, 1))
    dico(clé) = IIf(dico.Exists(clé), dico(clé) & "*" & temp(i, 2), temp(i, 2))
  Next i
  Me.ComboBox1.List = dico.keys
End Sub

Private Sub ComboBox1_click()
  Me.ListBox1.List = Split(dico(Me.ComboBox1.Value), "*")
End Sub

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

Autres versions

Form CodePostaux
Form CodePostaux2
Form CodePostaux3
Form CodePostaux4

Dim f, code, ville
  Private Sub UserForm_Initialize()
  Set MonDico = CreateObject("Scripting.Dictionary")
  Set f = Sheets("bd")
  Set code = f.Range("A2:A" & f.[A65000].End(xlUp).Row)
  Set ville = f.Range("B2:B" & f.[b65000].End(xlUp).Row)
  temp = code
  For i = 1 To UBound(temp, 1)
     MonDico(temp(i, 1)) = ""
  Next i
  Me.ComboBox1.List = MonDico.keys
  temp = ville
  For i = 1 To UBound(temp): temp(i, 1) = sansAccent(temp(i, 1)): Next i
  Call Tri(temp, 1, UBound(temp, 1))
  Me.ComboBox2.List = temp
End Sub

Private Sub ComboBox1_click()
  Me.ListBox1.Clear
  Set c = code.Find(Me.ComboBox1, , , xlWhole)
  j = 0
  If Not c Is Nothing Then
    premier = c.Address
    Do
      Me.ListBox1.AddItem c
      Me.ListBox1.List(j, 1) = c.Offset(, 1)
      j = j + 1
      Set c = code.FindNext(c)
    Loop While Not c Is Nothing And c.Address <> premier
  End If
End Sub

Private Sub TextBox1_Change()
  Me.ListBox1.Clear
  Set c = ville.Find(Me.TextBox1 & "*", , , xlWhole)
  j = 0
  If Not c Is Nothing Then
  premier = c.Address
  Do
    Me.ListBox1.AddItem c
    Me.ListBox1.List(j, 1) = c.Offset(, -1)
    j = j + 1
    Set c = ville.FindNext(c)
   Loop While Not c Is Nothing And c.Address <> premier
  End If
End Sub

Choix intuitif de la ville ou du code postal dans un combobox

Donne la correspondance Commune <--> CP.
La liste des villes apparaît au fur et à mesure de la frappe des caractères.

Communes Code postal
Communes code Insee

Autre exemple

La liste des villes apparaît au fur et à mesure de la frappe des caractères.

Form Saisie Ville CodePostal Intuitif

Private Sub ComboVille_Change()
  On Error Resume Next
  If ActiveControl.Name <> "ComboVille" Then Exit Sub
  On Error GoTo 0
  If Me.ComboVille.ListIndex = -1 And _
      IsError(Application.Match(Me.ComboVille, Application.Index(ListeVille, , 1), 0)) Then
     Dim b()
     clé = UCase(Me.ComboVille) & "*"
     n = 0
     For i = LBound(ListeVille) To UBound(ListeVille)
       If UCase(ListeVille(i, 1)) Like clé Then
         n = n + 1: ReDim Preserve b(1 To 2, 1 To n)
         b(1, n) = ListeVille(i, 1): b(2, n) = ListeVille(i, 2)
       End If
     Next i
     If n > 0 Then
       ReDim Preserve b(1 To 2, 1 To n + 1)
       Me.ComboVille.List = Application.Transpose(b)
       Me.ComboVille.RemoveItem n
     End If
     Me.ComboVille.DropDown
   Else
     On Error Resume Next
     Me.CodePostal = Me.ComboVille.Column(1)
   End If
End Sub

Private Sub CodePostal_Change()
  On Error Resume Next
  If ActiveControl.Name <> "CodePostal" Then Exit Sub
  On Error GoTo 0
  If Me.CodePostal.ListIndex = -1 And _
      IsError(Application.Match(Me.CodePostal, Application.Index(ListeVille, , 2), 0)) Then  
    Dim b()
    clé = UCase(Me.CodePostal) & "*"
    n = 0
    For i = LBound(ListeVille) To UBound(ListeVille)
      If UCase(ListeVille(i, 2)) Like clé Then
         n = n + 1: ReDim Preserve b(1 To 2, 1 To n)
         b(1, n) = ListeVille(i, 2): b(2, n) = ListeVille(i, 1)
      End If
   Next i
   If n > 0 Then
     ReDim Preserve b(1 To 2, 1 To n + 1)
     Me.CodePostal.List = Application.Transpose(b)
     Me.CodePostal.RemoveItem n
   End If
   Me.CodePostal.DropDown
 Else
    On Error Resume Next
    Me.ComboVille = Me.CodePostal.Column(1)
  End If
End Sub

Choix Département -> Code postal -> Ville

Form Code Postal ville

Dim f, Dpt, cp, ville
   Private Sub UserForm_Initialize()
   Set MonDico = CreateObject("Scripting.Dictionary")
   Set f = Sheets("bd")
   Set Dpt = f.Range("A2:A" & f.[A65000].End(xlUp).Row)
   Set cp = f.Range("b2:b" & f.[b65000].End(xlUp).Row)
   Set ville = f.Range("c2:c" & f.[c65000].End(xlUp).Row)
   temp = Dpt
   For i = 1 To UBound(temp, 1)
      MonDico(temp(i, 1)) = 1
   Next i
   Me.ComboBox1.List = MonDico.keys
   Me.ComboBox1.SetFocus
   SendKeys "{F4}"
End Sub

Private Sub ComboBox1_Change()
  Set MonDico = CreateObject("Scripting.Dictionary")
  d = Application.Match(Me.ComboBox1, Dpt, 0)
  Me.ComboBox2.Clear
  Me.ComboBox3.Clear
  For i = d To d + Application.CountIf(Dpt, Me.ComboBox1) - 1
     MonDico(cp(i).Value) = 1
  Next i
  Me.ComboBox2.List = MonDico.keys
  Me.ComboBox2.SetFocus
  SendKeys "{F4}"
End Sub

Private Sub ComboBox2_Change()
  If Me.ComboBox2 <> "" Then
    Me.ComboBox3.Clear
   d = Application.Match(Val(Me.ComboBox2), cp, 0)
   If IsError(d) Then d = Application.Match(Me.ComboBox2, cp, 0)
    For i = d To d + Application.CountIf(cp, Me.ComboBox2) - 1
      Me.ComboBox3.AddItem ville(i)
    Next i
    Me.ComboBox3.SetFocus
    SendKeys "{F4}"
  End If
End Sub

Private Sub ComboBox3_Change()
  ActiveCell = Me.ComboBox2
  ActiveCell.Offset(, 1) = Me.ComboBox3
  Unload Me
End Sub

Listes en cascade pays

On fait apparaître les produits du pays choisi.

Liste Cascade Pays

Private Sub UserForm_Initialize()
  Set mondico = CreateObject("Scripting.Dictionary")
  Set f = Sheets("BD")
  For Each c In Range(f.[C2], f.[C65000].End(xlUp))
    mondico.Item(c.Value) = c.Value
  Next c
  Me.ComboBox1.AddItem "*"
  For Each i In mondico.items
    Me.ComboBox1.AddItem i
  Next
End Sub

Private Sub ComboBox1_Change()
  i = 0
  Me.ListBox1.Clear
  Set f = Sheets("BD")
  For Each c In Range(f.[A2], f.[A65000].End(xlUp))
    If c.Offset(0, 2) = Me.ComboBox1 Or Me.ComboBox1 = "*" Then
      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
      Me.ListBox1.List(i, 3) = c.Offset(0, 3).Value
      i = i + 1
    End If
  Next c
End Sub

Listes en cascade triées

Form_CascadeTrie.xls
Form_Cascade2NivTrie.xls

Private Sub UserForm_Initialize()
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In Range([A2], [A65000].End(xlUp))
    If Not MonDico.Exists(c.Value) Then MonDico.Add c.Value, c.Value
  Next c
  temp = MonDico.items
  Call Tri(temp, LBound(temp), UBound(temp)) ' voir module mod_tri
  Me.ComboBox1.List = temp
End Sub

Private Sub ComboBox1_Change()
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In Range([A2], [A65000].End(xlUp))
    If c = Me.ComboBox1 Then
      If Not MonDico.Exists(c.Offset(0, 1).Value) Then
        MonDico.Add c.Offset(0, 1).Value, c.Offset(0, 1).Value
      End If
    End If
  Next c
  temp = MonDico.items
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ListBox1.List = temp
End Sub

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

Listes en cascade 3 niveaux non trié et trié

FormCascade3niv
FormCascade4niv

Version non trié

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range(f.[A2], f.[A65000].End(xlUp))
    mondico(c.Value) = c.Value
  Next c
  Me.ComboBox1.List = mondico.items
End Sub

Private Sub ComboBox1_Change()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range(f.[A2], f.[A65000].End(xlUp))
     If c = Me.ComboBox1 Then mondico(c.Offset(, 1).Value) = c.Offset(, 1).Value
  Next c
  Me.ComboBox2.List = mondico.items
  Me.ComboBox2.ListIndex = -1
  Me.ComboBox3.ListIndex = -1
End Sub

Private Sub ComboBox2_Change()
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In Range(f.[A2], f.[A65000].End(xlUp))
     If c = Me.ComboBox1 And c.Offset(, 1) = Me.ComboBox2 Then _
         mondico(c.Offset(, 2).Value) = c.Offset(, 2).Value
   Next c
   Me.ComboBox3.List = mondico.items
   Me.ComboBox3.ListIndex = -1
End Sub

Version trié

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range(f.[A2], f.[A65000].End(xlUp))
     mondico(c.Value) = c.Value
  Next c
  temp = mondico.items
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
End Sub

Private Sub ComboBox1_Change()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range(f.[A2], f.[A65000].End(xlUp))
    If c = Me.ComboBox1 Then mondico(c.Offset(, 1).Value) = c.Offset(, 1).Value
  Next c
  temp = mondico.items
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox2.List = temp
  Me.ComboBox2.ListIndex = -1
  Me.ComboBox3.ListIndex = -1
End Sub

Private Sub ComboBox2_Change()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range(f.[A2], f.[A65000].End(xlUp))
    If c = Me.ComboBox1 And c.Offset(, 1) = Me.ComboBox2 Then mondico(c.Offset(, 2)) = c.Offset(, 2)
  Next c
  If mondico.Count > 0 Then
    temp = mondico.items
    Call Tri(temp, LBound(temp), UBound(temp))
    Me.ComboBox3.List = temp
    Me.ComboBox3.ListIndex = -1
  End If
End Sub

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

Autre exemple

FormCascade3Niveaux

Private Sub UserForm_Initialize()
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In Range("catégorie")
    MonDico(c.Value) = c.Value
  Next c
  Me.ComboBox1.List = MonDico.items
End Sub

Private Sub ComboBox1_Change()
   Set MonDico = CreateObject("Scripting.Dictionary")
   a = [catégorie] ' recherche dans un tableau + rapide
    For i = 1 To Range("NbPorte").Count
      If a(i, 1) = Me.ComboBox1 Then
        temp = Range("NbPorte")(i)
        MonDico(temp) = temp
      End If
    Next i
    Me.ComboBox2.List = MonDico.items
    Me.ComboBox2.ListIndex = -1
    Me.ComboBox3.ListIndex = -1
End Sub

Private Sub ComboBox2_Change()
  Set MonDico = CreateObject("Scripting.Dictionary")
  a = [catégorie]
  b = [nbPorte]
  For i = 1 To Range("Couleur").Count
    If b(i, 1) = Val(Me.ComboBox2) And a(i, 1) = Me.ComboBox1 Then
      temp = Range("Couleur")(i)
      MonDico(temp) = temp
    End If
  Next i
  Me.ComboBox3.List = MonDico.items
  Me.ComboBox3.ListIndex = -1
End Sub

Autre exemple

Sur cet exemple, l'opérateur choisit un profil, un motif, un sous-motif.

FormCascade3niveaux

Private Sub UserForm_Initialize()
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In Range("profil")
    If Not MonDico.Exists(c.Value) Then MonDico.Add c.Value, c.Value
  Next c
  Me.profil.List = MonDico.items
End Sub

Private Sub profil_Change()
  Set MonDico = CreateObject("Scripting.Dictionary")
  For i = 1 To Range("motif").Count
    If Range("profil")(i) = Me.profil Then
      temp = Range("motif")(i)
      If Not MonDico.Exists(temp) Then
         MonDico.Add temp, temp
      End If
   End If
  Next i
  Me.Motif.List = MonDico.items
  Me.Motif.ListIndex = 0
End Sub

Private Sub Motif_Change()
  Set MonDico = CreateObject("Scripting.Dictionary")
  For i = 1 To Range("SousMotif").Count
    If Range("Motif")(i) = Me.Motif Then
      temp = Range("SousMotif")(i)
      If Not MonDico.Exists(temp) Then
         MonDico.Add temp, temp
      End If
    End If
   Next i
   Me.SousMotif.List = MonDico.items
   Me.SousMotif.ListIndex = 0
End Sub

Private Sub b_validation_Click()
'--- Positionnement dans la base
[A65000].End(xlUp).Offset(1, 0).Select
'--- Transfert Formulaire dans BD
ActiveCell.Value = Application.Proper(Me.nom)
ActiveCell.Offset(0, 1).Value = Me.Prenom
ActiveCell.Offset(0, 2).Value = CDbl(Me.age)
ActiveCell.Offset(0, 3).Value = Me.profil
ActiveCell.Offset(0, 4).Value = Me.Motif
ActiveCell.Offset(0, 5).Value = Me.SousMotif
ActiveCell.Offset(0, 7).Value = Now
ActiveCell.Offset(0, 8).Value = Environ("username")
End Sub

Private Sub b_fin_Click()
  Unload Me
End Sub

Listes en cascade 4 niveaux

Liste4niveaux
Liste4niveaux2
Liste4niveauxRayonTypeCatéArticle

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("finances")
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each C In Range("O3:O" & [O65000].End(xlUp).Row)
    mondico(C.Value) = ""
  Next C
  temp = mondico.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
End Sub

Private Sub ComboBox1_click()
  Me.ComboBox2.Clear
  Me.ComboBox3.Clear
  Me.ListBox1.Clear
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each C In Range("O3:O" & [O65000].End(xlUp).Row)
     If C = Me.ComboBox1 Then mondico(C.Offset(0, 1).Value) = ""
  Next C
  temp = mondico.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox2.List = temp
End Sub

Private Sub ComboBox2_click()
  Me.ComboBox3.Clear
  Me.ListBox1.Clear
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each C In Range("D3:D" & [D65000].End(xlUp).Row)
    If C.Offset(, 11) = Me.ComboBox1 And C.Offset(, 12) = Me.ComboBox2 Then mondico(C.Value) = ""
  Next C
  temp = mondico.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox3.List = temp
End Sub

Private Sub ComboBox3_click()
  Me.ListBox1.Clear
  i = 0
  For Each C In Range("J3:J" & [J65000].End(xlUp).Row)
    If C.Offset(, 5) = Me.ComboBox1 And C.Offset(, 6) = Me.ComboBox2 And C.Offset(, -6).Value =         CDate(Me.ComboBox3) Then
       Me.ListBox1.AddItem C
       Me.ListBox1.List(i, 1) = C.Offset(, 1)
       i = i + 1
    End If
  Next C
End Sub

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

Listes en cascade 5 niveaux

ComboBox5NiveauxTrié
ComboBox5NiveauxTriéRapide

Dim f, a()
Private Sub UserForm_Initialize()
  Set f = Sheets("parametres")
  Set mondico = CreateObject("Scripting.Dictionary")
  a = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value
  For i = LBound(a, 1) To UBound(a, 1)
    mondico(a(i, 1)) = ""
  Next i
  temp = mondico.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
End Sub

Private Sub ComboBox1_click()
  Me.ComboBox2.Clear
  Me.ComboBox3.Clear
  Me.ComboBox4.Clear
  Me.ComboBox5.Clear
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = LBound(a, 1) To UBound(a, 1)
     If a(i, 1) = Me.ComboBox1 Then mondico(a(i, 2)) = ""
  Next i
  temp = mondico.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox2.List = temp
End Sub

Private Sub ComboBox2_click()
  Me.ComboBox3.Clear
  Me.ComboBox4.Clear
  Me.ComboBox5.Clear
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = LBound(a, 1) To UBound(a, 1)
     If a(i, 1) = Me.ComboBox1 And a(i, 2) = Me.ComboBox2 Then mondico(a(i, 3)) = ""
  Next i
  temp = mondico.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox3.List = temp
End Sub

Private Sub ComboBox3_click()
  Me.ComboBox4.Clear
  Me.ComboBox5.Clear
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = LBound(a, 1) To UBound(a, 1)
    If a(i, 1) = Me.ComboBox1 And a(i, 2) = Me.ComboBox2 And a(i, 3) = Me.ComboBox3 Then mondico(a(i, 4)) = ""
  Next i
  temp = mondico.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox4.List = temp
End Sub

Private Sub ComboBox4_click()
  Me.ComboBox5.Clear
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = LBound(a, 1) To UBound(a, 1)
    If a(i, 1) = Me.ComboBox1 And a(i, 2) = Me.ComboBox2 And a(i, 3) = Me.ComboBox3 And a(i, 4) =        Me.ComboBox4 Then mondico(a(i, 5)) = ""
  Next i
  temp = mondico.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox5.List = temp
End Sub

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

Liste cascade ordre quelconque (simulation filtre automatique)

Les choix peuvent être fait dans un ordre quelconque.

FormCasCade
FormCasCade MAC
FormCasCade MAC2
FormCasCade2
FormCasCade2 Mac
FormCasCade3
FormCasCade2ListView
FormCasCade2ListView2
FormCasCadeLiens
FormCasCade6niveaux
Form ComboBox Intuitif pilote Filtre Automatique.xls
Form ComboBox Intuitif pilote Filtre Automatique2.xls

Simulation du filtre automatique avec choix des champs de sélection (dans un formulaire)

Les choix dans les comboBoxs se font dans un ordre quelconque comme dans le filtre automatique.
Le lien entre les colonnes critères de la BD et le formulaire est fait par les labels associés aux comboBoxs et les titres de la BD.
Le résultat du filtre peut être transféré dans une feuille du classeur.

Form CasCade Paramétré
Form CasCade Paramétré ListBox PC & Mac
Form CasCade Paramétré ListBox PC & Mac2

Pilotage d'un filtre automatique par un formulaire

Form ComboBox Intuitif.xls

Liste déroulante intuitive avec comboBox (saisie semi-automatique)

Noms commençant par les premières lettres dans un ComboBox

La saisie dans le combobox se fait de façon intuitive. La liste des noms apparaît au fur et et à mesure de la frappe des premières lettres (comme sur Google).

Pour obtenir la liste complète des noms faire un double-clic.
La propriété MacthEntry doit être positionée sur None

Liste Déroulante Intuitive TableurPrem Lettres

Private Sub ComboBox1_Change()
  If Me.ComboBox1 <> "" Then
    Set d1 = CreateObject("Scripting.Dictionary")
    tmp = UCase(Me.ComboBox1) & "*"
    For Each c In Sheets("BD").[liste]
      If UCase(c) Like tmp Then d1(c.Value) = ""
    Next c
    Me.ComboBox1.List = d1.keys
    Me.ComboBox1.DropDown
    [e2] = Me.ComboBox1
  End If
End Sub

Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  ComboBox1.List = Sheets("BD").Range("liste").Value
  Me.ComboBox1.DropDown
End Sub

Pour obtenir les noms qui contiennent les lettres frappées, Remplacer tmp = UCase(Me.ComboBox1) & "*" par tmp = "*" & UCase(Me.ComboBox1) & "*".

Simulation de Données/Validation avec saisie intuitive caractère par caractère

Données/validation permet la saisie intuitive (semi-automatique) :
-En frappant les premières lettres et en cliquant sur la flèche, on obtient la liste des items commençant par les lettres frappées. Mais elle ne permet pas d'obtenir la liste des items au fur et à mesure de la frappe des caractères comme sur Google.
-Ci dessous, lors du clic dans une cellule, un combobox apparaît, permettant une saisie intuitive caractère par caractère comme sur Google. La liste des noms de pays commençant par les lettres frappées apparaît automatiquement au fur et à mesure de la frappe des caractères.
Si on ne veut pas que la liste déroulante affiche tous les noms au clic dans la cellule, supprimer Me.ComboBox1.DropDown.

Liste déroulante Intuitive Tableur Multiple
Liste déroulante Intuitive Tableur Multiple lettres contenues
Liste déroulante Intuitive Planification
Liste déroulante Intuitive Villes
Liste conditionnelle intuitive produit
Liste conditionnelle intuitive Départ Ville

Dim a()
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([A2:A16], Target) Is Nothing And Target.Count = 1 Then
    a = Sheets("bd").Range("liste").Value
    Me.ComboBox1.List = Sheets("bd").Range("liste").Value
    Me.ComboBox1.Height = Target.Height + 3
    Me.ComboBox1.Width = Target.Width
    Me.ComboBox1.Top = Target.Top
    Me.ComboBox1.Left = Target.Left
    Me.ComboBox1 = Target
    Me.ComboBox1.Visible = True
    Me.ComboBox1.Activate
    Me.ComboBox1.DropDown ' ouverture automatique au clic dans la cellule
  Else
    Me.ComboBox1.Visible = False
  End If
End Sub

Private Sub ComboBox1_Change()
  If Me.ComboBox1 <> "" Then
    Set d1 = CreateObject("Scripting.Dictionary")
    tmp = UCase(Me.ComboBox1) & "*"
    For Each c In a
      If UCase(c) Like tmp Then d1(c) = ""
    Next c
    Me.ComboBox1.List = d1.keys
    Me.ComboBox1.DropDown
  End If
  ActiveCell.Value = Me.ComboBox1
End Sub

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

On recherche par exemple un intitulé d'article : Table bois peint blanc plateau zinc 1 tiroir
L'intitulé est retouvé en frappant : bois blanc tiroir

Liste intuitive plusieurs mots
Liste intuitive plusieurs mots plusieurs colonnes
Liste Intuitive Plusieurs mots désordre formulaire
Liste Intuitive Plusieurs mots désordre formulaire TextBox ListBox
Recherche_Texte Zone de texte Intuitive Multi_Mots
Recherche_Texte Cellule Intuitive Multi_Mots_Feuille

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

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

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

Dim f, choix(), Rng, Ncol
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set Rng = f.Range("a3:F" & f.[a65000].End(xlUp).Row)
  TblTmp = Rng.Value
  Ncol = Rng.Columns.Count
  For i = LBound(TblTmp) To UBound(TblTmp)
    ReDim Preserve choix(1 To i)
    For k = LBound(TblTmp) To UBound(TblTmp, 2)
      choix(i) = choix(i) & TblTmp(i, k) & " * "
    Next k
  Next i
  Me.ListBox1.List = Rng.Value
End Sub

Private Sub TextBox1_Change()
  If Me.TextBox1 <> "" Then
     mots = Split(Trim(Me.TextBox1), " ")
     Tbl = choix
     For i = LBound(mots) To UBound(mots)
        Tbl = Filter(Tbl, mots(i), True, vbTextCompare)
     Next i
     If UBound(Tbl) > -1 Then
        Dim b(): ReDim b(1 To UBound(Tbl) + 1, 1 To Ncol)
        For i = LBound(Tbl) To UBound(Tbl)
          a = Split(Tbl(i), "*")
          For k = 1 To Ncol: b(i + 1, k) = a(k - 1): Next k
        Next i
        Me.ListBox1.List = b
        Me.Label1.Caption = UBound(Tbl) + 1
     End If
  Else
     UserForm_Initialize
  End If
End Sub

Liste déroulante intuitive avec formulaire (saisie intuitive semi automatique comme Google)

La saisie dans le combobox se fait de façon intuitive. La liste des noms apparaît au fur et et à mesure de la frappe des premières lettres comme pour la recherche sur Google.

La propriété MacthEntry doit être positionnée sur None.

Pour obtenir la liste des noms contenant les lettres frappées, remplacer   tmp = UCase(Me.ComboBox1) & "*" par tmp = "*" & UCase(Me.ComboBox1) & "*"

Liste Déroulante Intuitive Form Début
Liste Déroulante Intuitive Form Début Mac
Liste Déroulante Intuitive Form Contenu
Liste Déroulante Intuitive Form Contenu Filter
Liste Déroulante Intuitive Form Contenu Filter2
Liste Déroulante Intuitive Form Contenu Filter Info
Liste Déroulante Intuitive Form Villes
Liste Intuitive formulaire 2 colonnes
Liste Intuitive formulaire ComboBox 2 colonnes
Liste Intuitive formulaire 2 colonnes 2
Liste Intuitive formulaire 2 colonnes Nom Numéro
Devis Intuitif formulaire 3 colonnes
Liste Intuitive formulaire 2 colonnes Pays
Liste Intuitive formulaire 2 colonnes Code ou Description
Recherche Intuitive problème

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


Code formulaire

Dim a()
Private Sub UserForm_Initialize()
  a = [liste].Value
  Me.ComboBox1.List = [liste].Value
End Sub

Private Sub ComboBox1_Change()
  Set d1 = CreateObject("Scripting.Dictionary")
  tmp = UCase(Me.ComboBox1) & "*"
  For Each c In a
     If UCase(c) Like tmp Then d1(c) = ""
  Next c
  Me.ComboBox1.List = d1.keys
  Me.ComboBox1.DropDown
End Sub

Private Sub CommandButton1_Click()
   ActiveCell = Me.ComboBox1
End Sub

Code feuille

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([A2:A50], Target) Is Nothing And Target.Count = 1 Then
      UserForm3.Left = Target.Left + 150
      UserForm3.Top = Target.Top + 70 - Cells(ActiveWindow.ScrollRow, 1).Top
      UserForm3.Show
  End If
End Sub

Autre exemple

Recherche Intuitive TextBox ListBox Form
Recherche Intuitive TextBox ListBox Form 2 Colonnes
Recherche Intuitive TextBox ListBox Form 2 Colonnes2
Recherche Intuitive TextBox ListBox plusieurs mots Form
Recherche_Intuitive Multi_Mots_Multi_Colonnes

Code formulaire

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

Private Sub TextBox1_Change()
  Me.ListBox1.Clear
    For Each c In [liste]
      If UCase(c) Like UCase(Me.TextBox1) & "*" Then Me.ListBox1.AddItem c
   Next c
End Sub

Private Sub TextBox2_Change()
   Me.ListBox1.Clear
   For Each c In [liste]
     If UCase(c) Like "*" & UCase(Me.TextBox2) & "*" Then Me.ListBox1.AddItem c
   Next c
End Sub

Private Sub ListBox1_Click()
   ActiveCell = Me.ListBox1
   Unload Me
End Sub

Recherche intuitive BD avec choix de la colonne de recherche

L'opérateur choisit la colonne de la BD dans laquelle la recherche intuitive doit s'effectuer.

Recherche intuitive BD avec choix de la colonne de recherche
Recherche BD avec choix de la colonne de recherche

La recherche intuitive se fait en frappant les premiers caractères. Si on veut qu'elle se fasse en frappant un mot contenu, remplacer:

tmp =Me.ComboBox2 & "*" par tmp = "*" & Me.ComboBox2 & "*"

Option Compare Text
Dim bd(), titre(), choix(), ColClé
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set Rng = f.Range("A2:N" & f.[a65000].End(xlUp).Row)
  bd = Rng.Value                                 ' BD dans un Array pour rapidié
  Ncol = Rng.Columns.Count
  titre = Application.Index(Rng.Offset(-1).Value, 1) ' Titres de la BD
  Me.ComboBox1.List = titre
  bd = Rng.Value
  Me.ListBox1.List = bd
End Sub

Private Sub ComboBox1_Change()       ' choix de la colonne de recherche
  If IsNumeric(Me.ComboBox1) Then tmp = Val(Me.ComboBox1) Else tmp = Me.ComboBox1
  ColClé = Application.Match(tmp, titre, 0)
  Me.Label2.Caption = Me.ComboBox1
  Set d1 = CreateObject("Scripting.Dictionary")
  For i = LBound(bd) To UBound(bd)       ' liste des choix de la colonne choisie sans doublons
     d1(bd(i, ColClé)) = ""
  Next i
  choix = d1.keys: Tri choix, LBound(choix), UBound(choix)  
  ComboBox2.List = choix
End Sub

Private Sub ComboBox2_Change()         ' recherche intuitive
   Set d1 = CreateObject("Scripting.Dictionary")
   tmp = Me.ComboBox2 & "*"
   For Each c In choix
     If c Like tmp Then d1(c) = ""
   Next c
   Me.ComboBox2.List = d1.keys
   Me.ComboBox2.DropDown
End Sub

Private Sub ComboBox2_click()             ' alimentation ListBox
   If IsNumeric(Me.ComboBox2) Then clé2 = Val(Me.ComboBox2) Else clé2 = Me.ComboBox2
    Me.ListBox1.List = FiltreMultiCol(bd, clé2, ColClé)
End Sub

Recherche intuitive d'une société dans un combobox

On recherche la société BERNARD:
-En frappant BER dans le combobox, on obtient la liste des sociétés contenant BER.
-Il suffit de choisir parmi les doublons affichés.

Recherche intuitive d'une société Filter
Recherche intuitive d'une société doublons gérants Filter
Recherche intuitive d'une société doublons gérants 2 colonnes

Option Compare Text
Dim f, ligneEnreg, choix1()
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  choix1 = Application.Transpose(f.Range("A2:A" & f.[a65000].End(xlUp).Row).Value)
  Me.ChoixSociete.List = choix1
  Me.ChoixSociete.SetFocus
End Sub

Private Sub ChoixSociete_Change()
  If Me.ChoixSociete.ListIndex = -1 And IsError(Application.Match(Me.ChoixSociete, choix1, 0)) Then
    Me.ChoixSociete.List = Filter(choix1, Me.ChoixSociete.Text, True, vbTextCompare)
    Me.ChoixSociete.DropDown
  Else
     ChoixSociete_click
  End If
End Sub

Saisie intuitive caractère par caractère sur le 1er choix et 2eme Choix

Sur cet exemple, la saisie intuitive caractère par caractère se fait sur le choix du composant et de la référence.

Formulaire cascade intuitif 2 niveaux Nom Prénom
Formulaire cascade intuitif 2 niveaux
Formulaire cascade intuitif 2 niveaux 2 Colonnes
Formulaire cascade intuitif 2 niveaux Choix colonne de recherche

Sur cet exemple, la saisie intuitive caractère par caractère se fait sur le choix du département et de la ville.

Liste intuitive Département/Ville Formulaire
Liste intuitive Ville Formulaire

Liste cascade intuitive 3 niveaux formulaire

Autre exemple

FormIntuitive2

Private Sub TextBox1_Change()
   Me.ListBox1.Clear
   For Each c In [noms]
     If UCase(c) Like "*" & UCase(Me.TextBox1) & "*" Then
         Me.ListBox1.AddItem c
    End If
  Next c
End Sub

Private Sub Ok_Click()
   If Me.ListBox1 <> -1 Then
     Commande.TextBox6 = Me.ListBox1
     Unload Me
   End If
End Sub

ComboBox intuitif multi-colonnes

FormComboBoxMultiColonnesIntuitif

Listes en cascade

Formcascade

Private Sub UserForm_Initialize()
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In [type1]
     If Not MonDico.Exists(UCase(c.Value)) And c <> "" Then
         MonDico.Add UCase(c.Value), UCase(c.Value)
     End If
  Next c
  Me.ComboBox1.List = MonDico.items
End Sub

Private Sub ComboBox1_Change()
  Set MonDico = CreateObject("Scripting.Dictionary")
  Me.ComboBox2.Clear
  For Each c In [type2]
    If UCase(c.Offset(0, -1)) = UCase(Me.ComboBox1) Then
       If Not MonDico.Exists(UCase(c.Value)) And c <> "" Then
          MonDico.Add UCase(c.Value), UCase(c.Value)
       End If
    End If
  Next c
  Me.ComboBox2.List = MonDico.items
End Sub

Private Sub ComboBox2_Change()
  k = 0
  Me.ListBox1.Clear
  For Each c In [type1]
    If UCase(c) = UCase(Me.ComboBox1) And UCase(c.Offset(0, 1)) = UCase(Me.ComboBox2) Then
       Me.ListBox1.AddItem
       Me.ListBox1.List(k, 0) = c.Offset(, 2)
       Me.ListBox1.List(k, 1) = c.Offset(, 3)
       Me.ListBox1.List(k, 2) = c.Offset(, 4)
       Me.ListBox1.List(k, 3) = c.Offset(, -1)
       k = k + 1
    End If
  Next c
End Sub

Private Sub ListBox1_Click()
   Sheets("choix").[B5] = Me.ListBox1.Column(3)
End Sub

Choix ligne de bus

Choix de la ligne de bus, de la direction puis de la station.

FormBus

Private Sub UserForm_Initialize()
   Me.ComboBox1.List = Application.Transpose([début].Resize(, [début].CurrentRegion.Columns.Count))
End Sub

Private Sub ComboBox1_Change()
  Me.ListBox1.Clear
  Me.ListBox2.Visible = True
  Me.Label2.Visible = True
  p = Rows([début].Row).Find(what:=Me.ComboBox1).Column
  n = Application.CountA(Columns([début].Column).Offset(, p - 1))
  Me.ListBox2.Clear
  Me.ListBox2.AddItem [début].Offset(1, p - 1)
  Me.ListBox2.AddItem [début].Offset(n - 1, p - 1)
End Sub

Private Sub ListBox2_Click()
  If Me.ListBox2 <> "" Then
     Me.ListBox1.Visible = True
     p = Rows([début].Row).Find(what:=Me.ComboBox1).Column
     n = Application.CountA(Columns([début].Column).Offset(, p - 1))
     If Me.ListBox2 <> Me.ListBox2.List(0) Then
       Me.ListBox1.List = [début].Offset(1, p - 1).Resize(n - 1).Value
     Else
       Me.ListBox1.Clear
       For i = n - 1 To 1 Step -1
         Me.ListBox1.AddItem [début].Offset(1, p - 1).Resize(n)(i)
      Next i
    End If
  End If
End Sub

Facture

Facture

Dim ComboProd(1 To 5) As New ClasseProdFacture
Dim TextQte(1 To 5) As New ClasseQteFacture
Private Sub UserForm_Initialize()
  For b = 1 To 5: Set ComboProd(b).GrProduitFact = Me("produit" & b): Next b
  For b = 1 To 5: Set TextQte(b).GrQteFact = Me("qte" & b): Next b
  For i = 1 To 5
    'Me("produit" & i).List = TriChamp(Application.Index([BdProduit4], , 1))
    Me("produit" & i).List = TriChamp(Range([J2], [J2].End(xlDown)))
  Next i
End Sub

Sub ChoixProduit(no)
  Me("libellé" & no) = Application.VLookup(Me("Produit" & no), [BdProduit4], 2, False)
  Me("Prix" & no) = Application.VLookup(Me("Produit" & no), [BdProduit4], 3, False)
  Calcul no
End Sub

Sub Calcul(no)
  If Me("Prix" & no) <> "" And Me("Qte" & no) <> "" Then
    Me("Total" & no) = CDbl(Me("Prix" & no)) * CDbl(Me("Qte" & no))
  End If
End Sub

Private Sub B_ok_Click()
  [D7] = Me.nom
  [D9] = Me.Rue
  [D11] = Me.Ville
  [C16].Select
  For i = 1 To 5
    ActiveCell = Me("produit" & i)
    ActiveCell.Offset(0, 1) = Me("Libellé" & i)
    ActiveCell.Offset(0, 2) = Val(Me("Prix" & i))
    ActiveCell.Offset(0, 3) = Val(Me("qte" & i))
    ActiveCell.Offset(1, 0).Select
  Next i
End Sub

Modules de classe

Public WithEvents GrProduitFact As MSForms.ComboBox
Private Sub GrProduitFact_Click()
  F_Facture.ChoixProduit Mid(GrProduitFact.Name, 8)
End Sub

Public WithEvents GrQteFact As MSForms.TextBox
Private Sub GrQteFact_change()
  F_Facture.Calcul Mid(GrQteFact.Name, 4)
End Sub

Devis multi lignes

DevisMultiLignes

Dim ComboCoul(1 To 5) As New ClasseCoul
Dim ComboProd(1 To 5) As New ClasseProd
Dim TextQte(1 To 5) As New ClasseQte
Private Sub UserForm_Initialize()
  For b = 1 To 5: Set ComboCoul(b).GrCouleur = Me("couleur" & b): Next b
  For b = 1 To 5: Set ComboProd(b).GrProduit = Me("produit" & b): Next b
  For b = 1 To 5: Set TextQte(b).GrQte = Me("qte" & b): Next b
  For i = 1 To 5
    Me("produit" & i).List = SansDoublonsTrié(Application.Index([BdProduit2], , 1))
  Next i
End Sub

Sub ChoixProduit(no)
  Me("couleur" & no).Clear
  For Each c In Range([J2], [j65000].End(xlUp))
    If c = Me("produit" & no) Then Me("couleur" & no).AddItem c.Offset(0, 1)
  Next c
End Sub

Sub ChoixCouleur(no)
  For i = 1 To [BdProduit2].Rows.Count
     If Me("produit" & no) = [BdProduit2].Cells(i, 1) _
        And Me("couleur" & no) = [BdProduit2].Cells(i, 2) Then
          Me("total" & no) = [BdProduit2].Cells(i, 3) * Val(Me("qte" & no))
     End If
  Next i
End Sub

Private Sub B_ok_Click()
  [D7] = Me.nom
  [D9] = Me.Rue
  [D11] = Me.Ville
  [C16].Select
  For i = 1 To 5
    ActiveCell = Me("produit" & i)
    ActiveCell.Offset(0, 1) = Me("couleur" & i)
    ActiveCell.Offset(0, 3) = Val(Me("qte" & i))
    ActiveCell.Offset(1, 0).Select
  Next i
End Sub

Modules de classe

Public WithEvents GrCouleur As MSForms.ComboBox
Private Sub GrCouleur_Click()
  F_Devis.ChoixCouleur Mid(GrCouleur.Name, 8)
End Sub

Public WithEvents GrProduit As MSForms.ComboBox
Private Sub GrProduit_Click()
  F_Devis.ChoixProduit Mid(GrProduit.Name, 8)
End Sub

Public WithEvents GrQte As MSForms.TextBox
Private Sub GrQte_change()
  F_Devis.ChoixCouleur Mid(GrQte.Name, 4)
End Sub

Liste en cascade 3 niveaux multi-sélection

DV3NivMultiSélection
DV3NivMultiSélection2
DV3NivMultiSélection3

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range(f.[A2], f.[A65000].End(xlUp))
     mondico(c.Value) = c.Value
  Next c
  Me.ListBox1.List = mondico.items
  Me.ListBox1.MultiSelect = fmMultiSelectMulti
End Sub

Private Sub ListBox1_Change()
   Me.ListBox3.Clear
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In Range(f.[A2], f.[A65000].End(xlUp))
     For k = 0 To Me.ListBox1.ListCount - 1
       If Me.ListBox1.Selected(k) = True Then
         If c = Me.ListBox1.List(k, 0) Then
           temp = c.Offset(, 1)
           mondico(temp) = temp
         End If
       End If
     Next k
   Next c
   Me.ListBox2.List = mondico.items
End Sub

Private Sub ListBox2_Change()
  Me.ListBox3.Clear
  For Each c In Range(f.[B2], f.[B65000].End(xlUp))
    For k = 0 To Me.ListBox2.ListCount - 1
      If Me.ListBox2.Selected(k) = True Then
        If c = Me.ListBox2.List(k, 0) Then Me.ListBox3.AddItem c.Offset(, 1)
      End If
    Next k
  Next c
End Sub

Private Sub b_ok_Click()
  temp = ""
  For k = 0 To Me.ListBox3.ListCount - 1
     If Me.ListBox3.Selected(k) = True Then temp = temp & Me.ListBox3.List(k, 0) & " "
  Next k
  ActiveCell = temp
  Unload Me
End Sub

Sélection multiple dans ListBox en cascade

Recherche Choix Multiple

Choix en cascade ListBox 3 niveaux

ListBox Cascade 3 niveaux

 

Listes en cascade au survol d'un combobox

La liste des pays pour un continent est modifiée au survol du du continent.

ComboBoxSurvol

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
    mondico(c.Value) = c.Value
  Next c
  Me.ComboBox1.List = mondico.items
End Sub

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (Me.ComboBox1.Font.Size * 1.2))
  If Me.ComboBox1.TopIndex >= 0 Then
    temp = ComboBox1.List(ligne + Me.ComboBox1.TopIndex)
    Me.ComboBox1 = temp
    Me.ListBox1.Clear
    For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
      If c = temp Then Me.ListBox1.AddItem c.Offset(0, 1)
    Next c
  End If
End Sub

Private Sub ListBox1_Click()
Me.TextBox1 = Me.ListBox1
End Sub

Listboxs en cascade avec curseur

La liste des produits pour un nom est modifiée au survol du nom.

ListBoxCurseur
ListBoxCurseur2
ListBoxCurseur3

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
    mondico.Item(c.Value) = c.Value
  Next c
  Me.ListBox1.List = mondico.items
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ListBox1.Font.Size * 1.18))
  If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
    Me.Curseur.Visible = True
    Me.Curseur.Top = ligne * ListBox1.Font.Size * 1.18 + Me.ListBox1.Top
    Me.ListBox1.ListIndex = -1
    Me.ListBox2.Clear
    temp = ListBox1.List(ligne + Me.ListBox1.TopIndex)
    For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
      If c = temp Then Me.ListBox2.AddItem c.Offset(0, 1)
    Next c
  Else
    Me.Curseur.Visible = False
  End If
End Sub

Private Sub ListBox2_Click()
  Me.TextBox1 = Me.ListBox2
End Sub

Choix successifs(listes différences)

On ne peut pas choisir plusieurs fois la même option

Choix successifs

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

Private Sub ListBox1_Click()
  Me.ListBox2.List = Me.ListBox1.List
  Me.ListBox2.RemoveItem Me.ListBox1.ListIndex
  Me.ListBox2.ListIndex = -1
  Me.ListBox3.Clear
End Sub

Private Sub ListBox2_Click()
  Me.ListBox3.List = Me.ListBox2.List
  Me.ListBox3.RemoveItem Me.ListBox2.ListIndex
  Me.ListBox3.ListIndex = -1
End Sub

Choix successifs avec ComboBox

On ne peut pas choisir plusieurs fois la même option.

ChoixSuccessifs



Dim liste, n
Private Sub UserForm_Initialize()
  n = 4
  creelistedispo
End Sub

Sub creelistedispo()
  Set f = Sheets("BD")
  Set liste = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row).Value
    liste(c) = ""
  Next
  For i = 1 To n
    If Me("combobox" & i).Value <> "" Then liste.Remove (Me("combobox" & i).Value)
  Next i
  For i = 1 To n: Me("ComboBox" & i).List = liste.keys: Next
End Sub

Private Sub ComboBox1_Click()
  creelistedispo
End Sub

Private Sub ComboBox2_Click()
  creelistedispo
End Sub

Private Sub ComboBox3_Click()
  creelistedispo
End Sub

Si les ComboBox sont dans le tableur

ChoixSuccessifsTableur

Sub auto_open()
  creelistedispo
End Sub

Sub creelistedispo()
  Set f = Sheets("BD")
  Set liste = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value
    liste(c) = ""
  Next
  For Each c In f.OLEObjects
     If TypeName(c.Object) = "ComboBox" Then
        If c.Object.Value <> "" Then liste.Remove c.Object.Value
     End If
  Next c
  For Each c In f.OLEObjects
    If TypeName(c.Object) = "ComboBox" Then c.Object.List = liste.keys
  Next c
End Sub

Choix multiples dans un combobox

FormChoixSuccessifsCombo

Dim choix
Dim témoin As Boolean
Private Sub ComboBox1_Click()
  p = InStr(choix, Me.ComboBox1)
  If p = 0 Then '-- ajout
     If choix = "" Then choix = Me.ComboBox1 Else choix = choix & ":" & Me.ComboBox1
     Me.ComboBox1 = choix
  Else ' suppression s'il est déjà choisi
    If Not témoin Then
      a = Split(choix, ":")
      témoin = (UBound(a) - LBound(a) = 1)
      choix = Left(choix, p - 1) & Mid(choix, p + Len(Me.ComboBox1) + 1)
      If Right(choix, 1) = ":" Then choix = Left(choix, Len(choix) - 1)
      Me.ComboBox1 = choix
   Else
     témoin = False
   End If
  End If
End Sub

WebBrowser dans un formulaire

WebBowser

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

Private Sub ListBox1_Click()
Me.Lien.Visible = True
Me.Lien.Caption = Me.ListBox1.Column(2)
Call Me.WebBrowser1.Navigate(Me.Lien.Caption)
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   ligne = Int(Y / (ListBox1.Font.Size * 1.18))
   If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
      Me.Lien.Visible = True
      Me.Lien.Caption = ListBox1.List(ligne + Me.ListBox1.TopIndex, 2)
      Call Me.WebBrowser1.Navigate(Me.Lien)
      Me.ListBox1.ListIndex = ligne + Me.ListBox1.TopIndex
   Else
      Me.Lien.Visible = False
   End If
End Sub

Gestion de films avec recherche intuitive

La recherche dans le ComboBox peut être intuitive (premières lettres ou lettres contenues). On peut frapper Eas pour Clint Eastwood ou Dollar pour Et pour Quelques Dollars

Form cascade Films
Form Films Saisie
Form recherche Films

Dim f, titre, col, choix1()
Option Compare Text
Private Sub UserForm_Initialize()
  Set f = Sheets("Liste")
  Me.OptionButton1 = True
  titre = "Acteur": AlimComboBox
  For e = 1 To 5: Me("etoile" & e).Visible = False: Next e
  Me.etoiledemi.Visible = False
  For e = 11 To 15: Me("etoile" & e).Visible = False: Next e
  Me.etoiledemi2.Visible = False
End Sub

Private Sub OptionButton1_Click()
  titre = "Acteur": AlimComboBox
End Sub

Private Sub OptionButton2_Click()
  titre = "Titre de film": AlimComboBox
End Sub

Sub AlimComboBox()
  col = Application.Match(titre, f.[A1:E1], 0)
  If IsError(col) Then Exit Sub
  Set mondico = CreateObject("Scripting.Dictionary")
  mondico.CompareMode = vbTextCompare
  a = Application.Transpose(f.Cells(2, col).Resize(f.Cells(65000, col).End(xlUp).Row).Value)
  For i = LBound(a) To UBound(a)
    If a(i) <> "" Then
      b = Split(a(i), ",")
     For j = LBound(b) To UBound(b)
       mondico(b(j)) = ""
     Next j
   End If
  Next i
  choix1 = mondico.keys
  Call Tri(choix1, LBound(choix1), UBound(choix1))
  Me.ComboBox1.ListIndex = -1
  Me.ComboBox1.List = choix1
  Me.ComboBox1.SetFocus
End Sub

Private Sub combobox1_Change()
  If Me.ComboBox1.ListIndex = -1 And IsError(Application.Match(Me.ComboBox1, choix1, 0)) Then
    Me.ComboBox1.List = Filter(choix1, Me.ComboBox1.Text, True, vbTextCompare)
    Me.ComboBox1.DropDown
  Else
    ComboBox1_click
  End If
End Sub

Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  AlimComboBox
End Sub

Private Sub ComboBox1_click()
  Set MaBD = f.Range("A2:K" & f.[A65000].End(xlUp).Row)
  bd = MaBD.Value
  c = Application.Match(titre, f.[A1:E1], 0)
  Me.ListBox1.Clear
  n = Application.CountIf(Application.Index(MaBD, , c), "*" & Me.ComboBox1 & "*")
  Dim b(): ReDim b(1 To n, 1 To 11)
  j = 0
  For i = LBound(bd) To UBound(bd)
   If InStr(bd(i, c), Me.ComboBox1) > 0 Then
     j = j + 1
     For k = 1 To 11: b(j, k) = bd(i, k): Next k
   End If
  Next i
  Me.ListBox1.List = b
  Me.ListBox1.ListIndex = 0
End Sub

Private Sub ListBox1_Click()
  For k = 1 To 11
    Me("textbox" & k) = Me.ListBox1.Column(k - 1)
  Next k
  For e = 1 To 5: Me("etoile" & e).Visible = False: Next e
  Me.etoiledemi.Visible = False
  For e = 11 To 15: Me("etoile" & e).Visible = False: Next e
  Me.etoiledemi2.Visible = False
  '-- note1
  note = Val(Replace(Me.TextBox6, ",", "."))
  If note > 5 Then note = 5
  For e = 1 To Int(note): Me("etoile" & e).Visible = True: Next e
  x = Int(note) + 1
  If x < 6 And note - Int(note) >= 0.5 Then
    Me.etoiledemi.Left = Me("etoile" & x).Left
    Me.etoiledemi.Top = Me("etoile" & x).Top
    Me.etoiledemi.Visible = True
  End If
  '---- note2
  note = Val(Replace(Me.TextBox7, ",", "."))
  If note > 5 Then note = 5
  For e = 1 To Int(note): Me("etoile" & e + 10).Visible = True: Next e
  x = Int(note) + 11
  If x < 16 And note - Int(note) >= 0.5 Then
     Me.etoiledemi2.Left = Me("etoile" & x).Left
     Me.etoiledemi2.Top = Me("etoile" & x).Top
     Me.etoiledemi2.Visible = True
   End If
   '---
   nom = Me.ListBox1
   répertoire = "c:\photos\"
   If Dir(répertoire & nom & ".jpg") <> "" Then
     Me.Image1.Picture = LoadPicture(répertoire & nom & ".jpg")
   Else
     Me.Image1.Picture = LoadPicture
   End If
End Sub

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

Private Sub B_préc2_Click()
  If Me.ListBox1.ListIndex > 0 Then
    Me.ListBox1.ListIndex = Me.ListBox1.ListIndex - 1
  End If
End Sub

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

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

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

 

 


 

 

 

 



 


 

 


 


Exemples

Form CodePostaux
Liste Cascade Pays
Form Cascade Trie
FormCascadeContinent
Liste intuitive
FormIntuitifMultiColonnes
FormCascade3niveaux
FormCasCade3niveaux