Sélection simple suivant une clé
Combobox en cascade 2 niveaux
Filtre ListBox par un TextBox
Filtre ListBox par un ComboBox
Filtre ListBox par une clé
Filtre Listbox 3 critères
Filtre entre 2 dates
Filtre avec choix colonne de filtre
Fitre 1 à 6 critères choisis dans le désordre
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 sur une colonne
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)
Pilotage Filtre Automatique
Liste déroulante intuitive (saisie intuitive
semi-automatique)
Recherche intuitive de plusieurs mots
Recherches intuitives multiples
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
Recherche intuitive
conditionnelle
Sélection simple suivant une clé
On veut la liste des personnes d'une ville.
Sélection
une clé
Sélection
une clé MAC
Dim f, BD()
Private Sub UserForm_Initialize()
Set f = Sheets("BD")
BD = f.Range("A2:B" & f.[B65000].End(xlUp).Row).Value
' Array BD() pour rapidité
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(BD) ' on explore la colonne de niveau
1
d(BD(i, 2)) = "" ' on ajoute l'élément
de la famille au dictionnaire
Next i
Me.ComboBox1.List = d.keys
End Sub
Private Sub ComboBox1_click()
Me.ListBox1.Clear
For i = 1 To UBound(BD)
If BD(i, 2) = Me.ComboBox1 Then Me.ListBox1.AddItem
BD(i, 1)
Next i
End Sub
ComboBox en cascade sans doublons
ComboBox2Niv
FormLSD
ListBox Cascade Pays
Ville
ListBox Cascade
Pays Ville2
Dim f, BD()
Private Sub UserForm_Initialize()
Set f = Sheets("base")
BD = f.Range("A2:C" & f.[B65000].End(xlUp).Row).Value
' Array BD() pour rapidité
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(BD)
' on explore la colonne de niveau 1
d(BD(i, 2)) = ""
' on ajoute l'élément de la famille au dictionnaire
Next i
Me.Famille.List = d.keys
End Sub
Private Sub Famille_click()
Me.SousFamille.Clear
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(BD) '
on explore la colonne de niveau 2
If BD(i, 2) = Me.Famille Then d(BD(i, 3)) = ""
' si famille alors on ajoute l'élément de la sous-famille
au dictionnaire
Next i
Me.SousFamille.List = d.keys
End Sub
Private Sub SousFamille_click()
For i = 1 To UBound(BD) ' on explore la colonne de niveau
1
If BD(i, 2) = Me.Famille And BD(i, 3) = Me.SousFamille
Then Me.Code = BD(i, 1)
Next i
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, BD()
Private Sub UserForm_Initialize()
Set f = Sheets("base")
BD = f.Range("A2:C" & f.[B65000].End(xlUp).Row).Value
' Array pour rapidité
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(BD) ' on explore la colonne de
niveau 1
d(BD(i, 2)) = "" '
on ajoute l'élément de la famille au dictionnaire
Next i
Tbl = d.keys
Tri Tbl, LBound(Tbl), UBound(Tbl)
Me.Famille.List = Tbl
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 ComboBox
Filtre
ComboBox
Filtre ComboBox
2
Filtre ListBox
Menus en cascade sur BD incompléte
Cascade
4 niveaux BD incompléte
DV
Cascades 4 niv BD Hôtel Formulaire
Autre exemple
Cascade 3 niveaux BD incompléte
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
Filtre
TextBox ListBox Choix colonne recherche Fiche
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 ComboBox
Filtre
ComboBox ListBox
Filtre
ComboBox ListBox Choix colonne recherche
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 ListBox multi-colonnes par un TextBox avec choix de la colonne de recherche
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é
Filtre ListBox
Clé entête listbox
Filtre
ListBox Clé2
Filtre
ListBox Clé colonnes non contigues
Filtre
ListBox Clé colonnes non contigues intuitif
Filtre
ListBox Clé colonnes non contigues Scroll
Filtre
ListBox Clé colonnes non contigues Modif Ajout Sup
Filtre
ListBox Clé colonnes non contigues Scroll Modif
Filtre ListBox
Clé boutons d'options
Dim f, bd
Option Compare Text
Private Sub UserForm_Initialize()
Set f = Sheets("bd")
Set d = CreateObject("Scripting.Dictionary")
bd = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
'Tri bd, LBound(bd), UBound(bd), 1 ' version tri
Me.ListBox1.List = bd
For i = LBound(bd) To UBound(bd)
d(bd(i, 3)) = ""
Next i
Me.ComboBox1.List = d.keys
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
Recherche
intuitive BD avec choix de la colonne de recherche modif
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
Autre exemple
Filtre par marque de véhicules avec Modification,Création, Suppression.
Filtre avec 3 critères
Ce pprogramme 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 3 combobox peuvent être définis.
Filtre
multi-colonnes 3 conditions Choix colonnes 3
Filtre multi-colonnes
2 conditions
Filtre
multi-colonnes 2 conditions Choix colonnes
Filtre multi-colonnes
3 conditions
Filtre
multi-colonnes 3 conditions Choix colonnes
Filtre
multi-colonnes 3 conditions Choix colonnes 2
Filtre
cascade multi-colonnes 2 combobox ListBox
Filtre entre 2 dates
Filtre avec choix de la colonne de filtre
Filtre
multi-colonnes choix colonne filtre
Filtre
multi-colonnes choix colonne filtre Tableau
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 5 comboboxs peuvent être définis.
Filtre
multi-colonnes 6 comboboxs
Form
Filtre 6 ComboBoxs tableau dynamique multi-pages
Form
Filtre 6 ComboBoxs tableau dynamique multi-pages Calculs
Form
Filtre 6 ComboBoxs tableau dynamique Scroll Frame
Filtre Interventions
Filtre
multi-colonnes choix colonne filtre
Filtre sur une année (ou plusieurs)
Filtre
année
Filtre
année & ville
Filtre
année plusieurs
Filtre
année plusieurs ville
Filtre
ListBox 2 dates
Filtre
ListBox 2 dates 2
Filtre ListBox 2 dates
3
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
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
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
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
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
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
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
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
ou
Private Sub ListBox1_Click()
col = Me.ListBox1.ListIndex + 1
Me.ListBox2.List = f.Cells(2, 1).Offset(, col - 1).Resize(Application.CountA(f.Columns(col))).Value
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
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
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
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
Option Compare Text
Dim f, Tbl()
Private Sub UserForm_Initialize()
Set f = Sheets("bd")
Tbl = f.Range("A2:D" & [A65000].End(xlUp).Row).Value
Me.ListBox1.List = Tbl
End Sub
Private Sub TextBox1_Change()
Me.ListBox1.Clear
n = 0
clé = Me.TextBox1 & "*"
For i = 1 To UBound(Tbl)
If Tbl(i, 2) Like clé Then
Me.ListBox1.AddItem
Me.ListBox1.List(n, 0) = Tbl(i, 1)
Me.ListBox1.List(n, 1) = Tbl(i, 2)
Me.ListBox1.List(n, 2) = Tbl(i, 3)
Me.ListBox1.List(n, 3) = Tbl(i, 4)
n = n + 1
End If
Next i
End Sub
Liste intuitive avec TextBox et filtrage par ComboBox
Liste intuitive textbox & combobox
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()
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.
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
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.
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
Form moteur recherche
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 de la ville ou du code postal dans un combobox
On veut alimenter 2 combobox: Choix par ville
et choix par code postal.
La BDD est triée par ville. Il faut donc
la trier par code postal pour alimenter le combobox CodePostal.
Le tri indexé d'un Array de 36.000 lignes et 10 colonnes est 3
fois plus rapide que l'inversion de toutes les colonnes (0,4 sec
au lieu de 1,2 sec).
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 postal sans
formulaire
Communes Code postal
sans formulaire IDF
Communes code Insee
Communes Code postal
ADO
Communes Communauté
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
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.
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é
Form
Cascade 3 niv
Form Cascade 3
niv mémoire
Form Cascade 4 niv
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
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.
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
Liste
4 niveaux
Liste
4 niveaux2
Liste 4
niveauxRayon Type Caté Article
Liste
4 niveaux générique(adaptable)
Liste
4 niveaux trié générique(adaptable)
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
Mac
FormCasCade3
FormCasCade2ListView
FormCasCade2ListView2
FormCasCadeLiens
FormCasCade6niveaux
Form ComboBox
Intuitif pilote Filtre Automatique.xls
Form
ComboBox Intuitif pilote Filtre Automatique2.xls
Form Modif lignes
filtrées
Pilotage filtre automatique
Les programmes ci dessous permettent de piloter des filtres auto à partir de 4 comboboxs:
-Les choix dans les comboboxs se font dans un ordre quelconque
-On peut choisir les colonnes de la BD affectés aux comboboxs.
Pilotage
filtre automatique avec 1 à 6 ComboBoxs
Pilotage filtre
automatique avec 1 à 10 ComboBoxs
Pilotage filtre
automatique avec 1 à 5 ComboBoxs + ListBox
Pilotage
filtre automatique sans formulaire avec 1 à 4 ComboBoxs
Dim f, bd, TabBD(), ColCombo()
Private Sub UserForm_Initialize()
Set f = Sheets("bd")
B_tout_Click
Set bd = f.Range("A2:F" & f.[A65000].End(xlUp).Row)
TabBD = bd.Value2
ColCombo = Array(1, 2, 3, 4) ' A adapter
For c = 1 To UBound(ColCombo) + 1: ListeCol c: Next c
For i = 1 To UBound(ColCombo) + 1: Me("label" &
i) = f.Cells(1, ColCombo(i - 1)): Next i
End Sub
Sub ListeCol(noCol)
Set MonDico = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(TabBD)
ok = True
For Cb = 0 To UBound(ColCombo)
ColBD = ColCombo(Cb)
If Cb + 1 <> noCol Then
If Not TabBD(i, ColBD)
Like Me("comboBox" & Cb + 1) Then ok = False
End If
Next Cb
If ok Then
tmp = TabBD(i, ColCombo(noCol - 1))
MonDico(tmp) = ""
End If
Next i
MonDico("*") = ""
temp = MonDico.keys
Tri temp, LBound(temp), UBound(temp)
Me("ComboBox" & noCol).List = temp
End Sub
Private Sub B_tout_Click()
On Error Resume Next
ActiveSheet.ShowAllData
For i = 1 To 4: Me("combobox" & i) = "*":
Next i
End Sub
Private Sub ComboBox1_DropButtonClick()
ListeCol 1
End Sub
Private Sub ComboBox2_DropButtonClick()
ListeCol 2
End Sub
Private Sub ComboBox3_DropButtonClick()
ListeCol 3
End Sub
Private Sub ComboBox4_DropButtonClick()
ListeCol 4
End Sub
Private Sub ComboBox1_Change()
f.[A1].AutoFilter Field:=ColCombo(0), Criteria1:=Me.ComboBox1
End Sub
Private Sub ComboBox2_Change()
f.[A1].AutoFilter Field:=ColCombo(1), Criteria1:=Me.ComboBox2
End Sub
Private Sub ComboBox3_Change()
f.[A1].AutoFilter Field:=ColCombo(2), Criteria1:=Me.ComboBox3
End Sub
Private Sub ComboBox4_Change()
f.[A1].AutoFilter Field:=ColCombo(3), Criteria1:=Me.ComboBox4
End Sub
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
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) & "*".
ComboBox intuitif et saisie de nouvelles valeurs
Option Compare Text
Dim choix()
Private Sub UserForm_Initialize()
Me.DateHeure = Now
choix = Application.Transpose([correspondant2].Value)
choix2 = Application.Transpose([sociétés2].Value)
Me.ComboBox1.List = choix
Me.ComboBox2.List = choix2
End Sub
Private Sub ComboBox1_Change()
Set d1 = CreateObject("Scripting.Dictionary")
tmp = UCase(Me.ComboBox1) & "*"
For Each c In choix
If UCase(c) Like tmp Then d1(c) = ""
Next c
Me.ComboBox1.List = d1.keys
Me.ComboBox1.DropDown
End Sub
Private Sub b_validation_Click()
enreg = [tableau1].Rows.Count + 1
[tableau1].Item(enreg, 1) = Now
[tableau1].Item(enreg, 2) = Me.TextBox1
[tableau1].Item(enreg, 3) = Me.TextBox2
[tableau1].Item(enreg, 4) = Me.ComboBox2
[tableau1].Item(enreg, 5) = Me.ComboBox1
End Sub
Private Sub b_nouveau_Click()
enreg = [correspondant2].Rows.Count + 1
[correspondant2].Item(enreg, 1) = Me.ComboBox1
End Sub
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
Liste
déroulante noms doublons
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 ComboBox
Liste intuitive
plusieurs mots ComboBox 2
Liste
intuitive plusieurs mots ComboBox 3
ComboBox intuitif 2
colonnes
Liste
intuitive plusieurs mots ComboBox OU
Liste intuitive
plusieurs mots plusieurs colonnes
Liste
Intuitive Plusieurs mots désordre formulaire
Liste
Intuitive Plusieurs mots désordre formulaire 2
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 plusieurs mots TextBox ListBox plusieurs colonnes
Recherche
intuitive 3 TextBox ListBox plusieurs colonnes
Recherche intuitive
questions réponses
Recherche intuitive
questions réponses 2
Recherche intuitive
questions réponses 3
Recherches intuitives multiples de plusieurs mots séparés par le caractère espace
Les recherches multiples sont séparées par des virgules.
Liste intuitive plusieurs mots & multiple
Option Compare Text
Dim f, Choix()
Private Sub UserForm_Initialize()
Set f = Sheets("bd")
Choix = Application.Transpose(f.Range("a2:a" &
f.[A65000].End(xlUp).Row))
Me.ListBox1.List = Choix
End Sub
Private Sub TextBox1_Change()
Set d1 = CreateObject("scripting.dictionary")
mots = Split(Trim(Me.TextBox1), ",")
For Each m In mots
mots2 = Split(Trim(m), " ")
Tbl = Choix
For i = LBound(mots2) To UBound(mots2)
Tbl = Filter(Tbl, mots2(i),
True, vbTextCompare)
Next i
For i = LBound(Tbl) To UBound(Tbl): d1(Tbl(i))
= "": Next i
Next m
Me.ListBox1.List = d1.keys
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
Form
Recherche 6 ComboBox TextBox intuitif
Form
Recherche 6 ComboBox TextBox intuitif tableau
Form
Recherche 6 ComboBox TextBox intuitif tableau spécial
Form
Recherche 6 ComboBox TextBox intuitif Dates
Recherche_Intuitive
Multi_Mots_TextBox Modif Ajout Sup
Recherche_Intuitive
Multi_Mots_TextBox Modif Ajout Sup ComboBox
Form
recherche intuitive tableau dynamique
Form
recherche intuitive tableau dynamique multi-pages
Form
recherche intuitive tableau dynamique Scroll Frame
Recherche_Intuitive
Multi_Mots_TextBox Modif Ajout Sup Option ComboBox
Recherche_Intuitive
Multi_Mots_TextBox Modif Ajout Sup Boutons Option
Recherche_Intuitive
Multi_Mots_Adresses
Recherche_Intuitive
Multi_Mots_TextBox Modif Ajout Sup Histo
Liste
Intuitive Plusieurs mots désordre formulaire TextBox ListBox Multi-colonnes
Liste
Intuitive Plusieurs mots questions réponses
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
Liste
Intuitive Plusieurs mots désordre formulaire CombotBox Multi-colonnes
Choix Col
Liste
Intuitive Plusieurs mots désordre formulaire CombotBox Multi-colonnes
Choix Col2
Liste
Intuitive Plusieurs mots désordre formulaire CombotBox Multi-colonnes
Choix Col Scroll
Recherche_Intuitive
Multi_Mots_Multi_Colonnes ListView
Recherche_Intuitive
Multi_Mots_Multi_Colonnes ListView 2
Recherche_Intuitive
Multi_Mots_Zone de texte Modif Ajout Sup
Recherche_Intuitive
avec choix de la colonne de recherche
Recherche
bibliothèque multi-colonnes et multi-mots
Recherche
bibliothèque multi-colonnes et multi-mots tableur
Annuaire
Recherche
multi-mots multi-colonnes
Recherche
multi-mots multi-colonnes ET OU
Apports Lipides
Protides Glucides
ComboBox
Conditionnel Intuitif
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 Auto-Sélection
Comparaison
TextBox/ListBox intuitif avec ComboBox Intuitif
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 cellule multi-lignes
Liste Intuitive
formulaire 3 colonnes
Liste Intuitive
formulaire 3 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
Liste
déroulante intuitive Form 3 niveaux PC MAC
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 TextBox ListBox plusieurs mots Form Mac
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
Liste
cascade intuitive 3 niveaux formulaire TAB
Autre exemple
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
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.
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
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
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
Choix en cascade ListBox 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.
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
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
Cascade ListBox
Dim f, BD(), choix(), Rng
Private Sub UserForm_Initialize()
Set f = Sheets("Feuil1")
Set Rng = f.Range("A2:B" & f.[A65000].End(xlUp).Row)
BD = Rng.Value
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(BD)
a = Split(BD(i, 2), ",")
For j = LBound(a) To UBound(a): d(Trim(a(j)))
= "": Next j
Next i
choix = d.keys
Me.ListBox1.List = d.keys
End Sub
Private Sub TextBox1_Change()
Tbl = Filter(choix, Trim(Me.TextBox1), True, vbTextCompare)
Me.ListBox1.List = Tbl
End Sub
Private Sub ListBox1_Click()
métier = Me.ListBox1
Dim Tbl()
n = 0
For i = 1 To UBound(BD)
If BD(i, 2) Like "*" & métier
& "*" 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.ListBox2.Column = Tbl Else Me.ListBox2.Clear
End Sub
Choix successifs avec ComboBox
On ne peut pas choisir plusieurs fois la même option.
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
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
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
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
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
Cascade 2 pères
Exemples |
| Form CodePostaux |
| Liste Cascade Pays |
| Form Cascade Trie |
| FormCascadeContinent |
| Liste intuitive |
| FormIntuitifMultiColonnes |
| FormCascade3niveaux |
| FormCasCade3niveaux |