La technique classique des listes en cascade utilise les
noms de champs et la fonction
=Indirect()
La maintenance des noms de champs en cas d'ajout/suppression peut devenir
fastidieuse
lorsque le nombre de champs devient important.
En outre, les listes en cascade avec Indirect() ne supportent
pas les champs dynamiques.
L'utilisation de la fonction Decaler() évite le nommage des listes et la gestion des contraintes sur les noms de champs(pas d'espace ou de caractères spéciaux)
L'utilisation d'une BD et de la fonction Decaler()
facilite la maintenance des listes en cascade
et permet en outre la récupération d'informations associées
aux listes (le prix d'une référence
produit par ex).
Listes en cascade avec noms de champ et Indirect()
La liste des modèles en B2 dépend de la marque choisie en A2:
Cascade_indirect.xls
Cascade_indirect
Formulaire.xls
- Nommer Marque le champ E2:E4 (Sélection E2:E4 puis Insertion/Nom/Définir)
- Nommer Renault le champ G2:G5 (doit
avoir le nom du contenu de E2)
- Nommer Citroen le champ G8:G10 (doit avoir le nom du
contenu de E3)
- Nommer Peugeot le champ G13:G15 (doit avoir le nom
du contenu de E4)
- Sélectionner A2
- Données/Validation
- Choisir Liste
puis =Marque dans Source
- Sélectionner B2
- Données/Validation
- Choisir Liste puis
=INDIRECT(A2)
-Les listes nommées peuvent être sur un autre onglet.
MFC pour vérifier si le second menu est
bien positionné.
=NB.SI(INDIRECT(A2);B2)=0
Pour une RAZ du 2e menu si modification du premier menu.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("a2:a2"), Target) Is Nothing
And Target.Count = 1 Then
Application.EnableEvents = False
Target.Offset(0, 1) = Empty
Application.EnableEvents = True
End If
End Sub
Positionement sur le 1er élément de la liste pour le second menu
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("a2:a2"), Target) Is Nothing
And Target.Count = 1 Then
Application.EnableEvents = False
temp = Range(Target)(1)
Target.Offset(0, 1) = temp
Application.EnableEvents = True
End If
End Sub
Noms avec espaces
Les nom de champs avec des espaces ne sont pas acceptés. Il faut utiliser:
=INDIRECT(SUBSTITUE(B2;" ";"_"))
Avec Prix
Pour obtenir le prix en C2
=INDEX(DECALER(INDIRECT(A2);;1);EQUIV(B2;INDIRECT(A2);0))
DvCascadeIndirectPrix
DvCascadeIndirectPrixParc
DvCascadeIndirectPrix2
DvCascadeIndirectPrixQte
Autre exemple
L'opérateur frappe la première lettre du produit pour obtenir la liste des produits commençant par la lettre choisie.
Menu1:=DECALER(fourn;EQUIV(A5&"*";fourn;0)-1;;NB.SI(fourn;A5&"*"))
Menu2:=DECALER(INDIRECT(A5);EQUIV(B5&"*";INDIRECT(A5);0)-1;;NB.SI(INDIRECT(A5);B5&"*"))
Pour effectuer le choix dans une seule cellule
En B2: =SI(NB.SI(Marque;B2)=0;Marque;INDIRECT(B2))
DVCascadeIndirectUneCellule
DVCascadeIndirectUneCellulePrix
3 niveaux
- Sélectionner C2
- Données/Validation
- Choisir Liste puis
=INDIRECT(B2)
Listes dynamiques et Indirect
Indirect() n'accepte pas les noms de champ dynamiques crées avec Decaler(). Sur cette version, on peut ajouter des items en ligne et en colonne.
Cascade_indirect
dyn.xls
Cascade_indirect
dyn premières lettres.xls
1- Nommer Marque =DECALER(Listes!$A$1;;;;NBVAL(Listes!$1:$1))
2 - nommer
Renault A:A
Citroën B:B
Peugeot C:C
3 - Pour le second menu en B2
Données/Validation/Liste
=DECALER(INDIRECT($A$2);1;;NBVAL(INDIRECT(A2))-1)
Création de listes à partir d'une BD
A partir de la BD, un progamme crée des listes nommées
utilisables avec Indirect()
Après la création des listes, la BD peut être supprimée
.
DV cascade
prix simple
DV cascade prix qte
Listes en cascade avec noms de champ et Si()
Si le nombre de listes est limité (7), on peut utiliser
une formule avec Si().
Les listes peuvent être dynamiques.
=SI(B2="Etudes";Etudes;SI(B2="Fabric";fabric;SI(B2="Compta";compta)))
Listes en cascade avec onglets
Pour chaque marque, un onglet contient la liste des modèles.
1 - Nommer Marque le champ E2:E4 (Sélection
E2:E4 puis Insertion/Nom/Définir)
2 - Pour le second menu en B2
. Données/Validation/Liste
. =DECALER(INDIRECT("'"&A2&"'!A2");;;NBVAL(INDIRECT("'"&A2&"'!$A:$A"))-1)
ou
. créer un nom de champ ListeModeles
. =DECALER(INDIRECT($A$2&"!$A$2");;;NBVAL(INDIRECT($A$2&"!$A:$A"))-1)
Pour obtenir le prix en C2: =RECHERCHEV(B2;INDIRECT("'"&A2&"'!A2:B10");2;FAUX)
DVCascadeOnglets
DVCascadeOnglets2
Pour obtenir la liste des onglets automatiquement
Listes en cascade (sans noms de champ)
Avec cette version:
-2 noms de champ suffisent pour gérer plusieurs listes.
-On peut ajouter des items en colonne et en ligne sans aucune modification:
DVListeCascade
DVListeCascade2
DVCascadeBâtiment
DVCommission
DVCascadeHorizontal
DVCouleur
DVCascadePremLettre
DVRecherche BD
DVCascade5
Nommer les champs:
choix1:=DECALER($F$1;;;;NBVAL($F$1:$Z$1))
choix2:=$F:$F
Dans Données/Validation/Liste
1ere liste en B2: =Choix1
2eme liste enC2: =DECALER(choix2;1;EQUIV(B2;Choix1;0)-1;NBVAL(DECALER(choix2;;EQUIV(B2;Choix1;0)-1))-1)
Les listes sont copiables
Options
MFC sur choix2 pour signaler mauvais choix:
=ESTNA(EQUIV(C2;DECALER(Choix2;1;EQUIV(B2;Choix1;0)-1;NBVAL(DECALER(Choix2;;EQUIV(B2;Choix1;0)-1))-1);0))
Positionnement sur le premier élément:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" And Target.Count = 1
Then
Target.Offset(0, 1) = Range("choix2")(1).Offset(1,
Application.Match(Target, [choix1], 0) - 1)
End If
End Sub
RAZ du second menu si modif du premier menu
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" And Target.Count = 1
And Target <> "" Then
Target.Offset(0, 1) = Empty
End If
End Sub
Ajout dynamique d'items dans les listes
L'opérateur peut saisir des items qui n'appartiennent pas aux listes. Ils sont ajoutés automatiquement.
ListeEnCascadeAjoutDynamique
ListeEnCascadeAjoutDynamiqueUneCellule
ListeEnCascadeAjoutDynamiqueUneCelluleTrié
Private Sub Worksheet_Change(ByVal Target As Range)
Set f = Sheets("listes")
If Target.Address = "$B$2" And Target.Count = 1
Then
If Target <> "" Then
If IsError(Application.Match(Target.Value,
[choix1], 0)) Then
If MsgBox("On ajoute?",
vbYesNo) = vbYes Then
[choix1].End(xlToRight).Offset(0,
1) = Target.Value
c = f.Range("choix2").Column
n = Application.CountA([choix1])
f.Range(f.Cells(1,
c), f.Cells(10, c + n)).Sort _
Key1:=f.Cells(1,
c), Order1:=xlAscending, Header:=xlNo, _
Orientation:=xlLeftToRight
Else
Application.EnableEvents
= False
Application.Undo
Application.EnableEvents
= True
End If
Else
Target.Offset(0, 1) =
f.Range("choix2")(1).Offset(1, Application.Match(Target, [choix1],
0) - 1)
End If
End If
End If
If Target.Address = "$C$2" And Target.Count = 1 Then
If Target <> "" Then
d = Application.Match(Target.Offset(0, -1),
[choix1], 0) - 1
If IsError(Application.Match(Target.Value,
[choix2].Offset(0, d), 0)) Then
If MsgBox("On ajoute?",
vbYesNo) = vbYes Then
n = Application.CountA([choix2].Offset(0,
d))
c = f.Range("choix2").Column
f.Cells(n + 1, c
+ d) = Target.Value
If n > 1 Then
f.Range(f.Cells(2,
c + d), f.Cells(n + 1, c + d)).Sort _
Key1:=f.Cells(2,
c + d), Order1:=xlAscending, _
Orientation:=xlTopToBottom,
Header:=xlNo
End If
Else
On Error Resume
Next
Application.EnableEvents
= False
Application.Undo
Application.EnableEvents
= True
End If
End If
End If
End If
End Sub
Récupération du commentaire
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
If Not Target.Offset(, 1).Comment Is Nothing Then
Application.EnableEvents = False
Target.Offset(, 1).Comment.Delete
Application.EnableEvents = True
End If
End If
If Target.Column = 2 And Target.Count = 1 Then
If Target <> "" Then
d = Application.Match(Target.Offset(0,
-1), [choix1], 0) - 1
If Not IsError(Application.Match(Target.Value,
[choix2].Offset(0, d), 0)) Then
Application.EnableEvents
= False
p = Application.Match(Target,
[choix2].Offset(0, d), 0)
c = Sheets("listes").Range("choix2").Column
Sheets("listes").Cells(p,
c + d).Copy
Target.PasteSpecial
Paste:=xlPasteComments
Application.EnableEvents
= True
End If
End If
End If
End Sub
Version avec Prix
ListeCascadesPrix
ListeCascadesChantiers
ListeCascadesChantiers2
Dans Données/Validation en B5
=DECALER(choix2;1;EQUIV(B5;choix1;0)-1;NBVAL(DECALER(choix2;;EQUIV(B5;choix1;0)-1))-1)
En D5
=SI(B5<>"";INDEX(DECALER(choix2;1;EQUIV(B5;choix1;0);50);
EQUIV(C5;DECALER(choix2;1;EQUIV(B5;choix1;0)-1;50);0));0)
Ouverture automatique des listes
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Range("B2:B10,C2:C10"), Target)
Is Nothing And Target.Count = 1 Then
SendKeys "%{down}"
End If
End Sub
Positionnement sur premier élément
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Count = 1 Then
x = Application.Match(Target, [choix1],
0)
Target.Offset(0, 1) = Sheets("Listes").Range("choix2")(1).Offset(1,
(x - 1))
End If
End Sub
Listes en cascade dans une seule cellule
On a un seul menu déroulant. On choisit d'abord la catégorie puis le choix dans la catégorie.
DvCascadeUneCellule
DvCascadeUneCelluleChoixMultiple
choix1:=DECALER($F$1;;;;NBVAL($F$1:$Z$1))
choix2:=$F:$F
=SI(NB.SI(Choix1;C2)=0;Choix1;DECALER(Choix2;1;EQUIV(C2;Choix1;0)-1;NBVAL(DECALER(Choix2;;EQUIV(C2;Choix1;0)-1))-1))
Ouverture de liste automatique
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$C$2" And Target.Count = 1
Then
SendKeys "%{down}"
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$2" And Target.Count = 1
Then
Set c = [choix1].Find(what:=Target.Value)
If Not c Is Nothing Then SendKeys "%{down}"
End If
End Sub
Avec libellé et prix
Dans Données/Validation
en A12
=SI(NB.SI(choix1;A12)=0;Liste1;DECALER(choix2;1;EQUIV(A12;choix1;0)-1;
NBVAL(DECALER(choix2;;EQUIV(A12;choix1;0)-1))-1))
Libellé en B12
=SI(A12<>"";INDEX(données;MAX((données=A12)*LIGNE(données))
-LIGNE(données)+1;MAX((données=A12)*COLONNE(données))-COLONNE(données)+2);"")
Valider avec Maj+ctrl+entrée
Version VBA
Liste en cascade 2 niveaux avec plusieurs choix de niveau 2
Pour un choix de niveau1, on a plusieurs choix de niveau
2 (couleur,taille,remise).
Les données des produits sont organisées en blocs espacés
de 10 lignes.
Noms de champ
Liste1 =DECALER(Feuil1!$F$2;;;NBVAL(Feuil1!$F:$F)-1)
Couleur =Feuil1!$I$2:$I$8
Remise =Feuil1!$K$2:$K$8
Taille =Feuil1!$J$2:$J$8
Menu couleur:=DECALER(couleur;(EQUIV(A3;Liste1;0)-1)*10;;NBVAL(DECALER(couleur;(EQUIV(A3;Liste1;0)-1)*10;0)))
Menu taille:=DECALER(taille;(EQUIV(A3;Liste1;0)-1)*10;;NBVAL(DECALER(taille;(EQUIV(A3;Liste1;0)-1)*10;0)))
Menu remise:=DECALER(Remise;(EQUIV(A3;Liste1;0)-1)*10;;NBVAL(DECALER(Remise;(EQUIV(A3;Liste1;0)-1)*10;0)))
Listes cascade sans noms de champ 3 niveaux
Le même modèle de voiture ne doit pas exister pour 2 marques:
Choix Modèle=DECALER(marque;1;EQUIV(A2;marque;0)-1;NBVAL(DECALER(INDEX(marque;1);1;EQUIV(A2;marque;0)-1;4;));1)
Choix couleur:=DECALER(modele;1;EQUIV(B2;modele;0)-1;NBVAL(DECALER(INDEX(modele;1);1;EQUIV(B2;modele;0)-1;6;));1)
DV
Sans Nom Champ 3niveaux
DV Sans Nom
Champ 3niveaux 2
DV Sans
Nom Champ 3niveaux Equipe
Cette version permet d'avoir le même modèle dans plusieurs marques.
DV
Sans Nom Champ 3niveaux
DV
Sans Nom Champ 3niveaux Equipe
Menu modèle:=DECALER(marque;1;EQUIV(A3;marque;0)-1;;NB.SI(marque;A3))
Menu couleurs: =DECALER(modele;1;EQUIV(B3;DECALER(modele;;EQUIV(A3;marque;0)-1);0)-1+EQUIV(A3;marque;0)-1;NBVAL(DECALER(INDEX(modele;1);1;EQUIV(B3;DECALER(modele;;EQUIV(A3;marque;0)-1);0)-1+EQUIV(A3;marque;0)-1;6;));1)
Autre exemple
Le 3e niveau est constitué de blocs espacés de 10 en 10. Des items peuvent être ajoutés sans modification des formules.
Noms de champ
choix1 =DECALER(données!$A$1;;;;NB.SI(données!$A$1:$K$1;"<>0"))
choix2 =données!$A$2:$A$15
choix3 =données!$P$1:$AA$1
choix4 =données!$P$2:$P$7
Menu1: =choix1
Menu2: =DECALER(choix2;;EQUIV(A5;choix1;0)-1;NB.SI(DECALER(choix2;;EQUIV(A5;choix1;0)-1);"<>0"))
Menu3: =DECALER(DECALER(choix4;(EQUIV(A5;choix1;0)-1)*10;0);;EQUIV(B5;DECALER(choix3;(EQUIV(A5;choix1;0)-1)*10;0);0)-1;NBVAL(DECALER(DECALER(choix4;(EQUIV(A5;choix1;0)-1)*10;0);;EQUIV(B5;DECALER(choix3;(EQUIV(A5;choix1;0)-1)*10;0);0)-1)))
DV3Niv
DV3NivB
DV3NivC
DV3nomsChamp
DV3nivPrix
DV3nivCroisé
Options
Raz des menus
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([A5:A10], Target) Is Nothing Then
Target.Offset(0, 1) = Empty
Target.Offset(0, 2) = Empty
End If
If Not Intersect([b5:b10], Target) Is Nothing Then Target.Offset(0,
1) = Empty
End Sub
Ouverture auto des menus
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([A5:C10], Target) Is Nothing Then SendKeys
"%{down}"
End Sub
Les listes de niveau 2 et 3 sont placées dans des onglets (modèles & couleurs)
Noms de champ à créer
choix1 =DECALER(Marques!$A$1;;;NBVAL(Marques!$A:$A))
Placer le curseur en B2
choix2 =DECALER(INDIRECT("'"&Menus!$A2&"'!A1");;;;NBVAL(INDIRECT("'"&Menus!$A2&"'!$1:$1")))
Placer le curseur en C2
choix3 =DECALER(INDIRECT(Menus!$A2&"!a1");1;EQUIV(Menus!$B2;choix2;0)-1;NBVAL(DECALER(INDIRECT(Menus!$A2&"!a:a");;EQUIV(Menus!$B2;choix2;0)-1))-1)
Autre version
Modèle: =DECALER(choix2;;EQUIV(A5;choix1;0)-1;NBVAL(DECALER(choix2;;EQUIV(A5;choix1;0)-1)))
Couleur: =DECALER(choix4;EQUIV(B5;choix3;0)-1;;1;NBVAL(DECALER(choix4;EQUIV(B5;choix3;0)-1;)))
Choix d'un arrêt de bus
On choisit la ligne de bus, la direction puis la station.
Menu2:
=DECALER(choix3;1;EQUIV(A2;choix1;0)-1;2)
Menu3:
=SI(EQUIV(B2;DECALER(choix3;1;EQUIV(A2;choix1;0)-1;2);0)=1;
DECALER(choix4;1;EQUIV(A2;choix1;0)-1;NBVAL(DECALER(choix2;;EQUIV(A2;choix1;0)-1))-1);
DECALER(choix2;1;EQUIV(A2;choix1;0)-1;NBVAL(DECALER(choix2;;EQUIV(A2;choix1;0)-1))-1))
Listes en cascade avec BD 2 niveaux
Sur cet exemple, la BD est triée. On obtient dans le second menu en H2 la liste des personnes de l'unité choisie en G2
En H2: Données/Validation/Liste
=DECALER(Nom;EQUIV(G2;unite;0)-1;0;NB.SI(unite;G2))
Liste
Cascade Triée
Liste
Cascade BD non triée
Liste
Cascade Catégorie/Produit
Liste
Cascade Triée Automatiquement
Liste
Cascade 2 niv Premières lettres 2eme niveau
Liste
Cascade Magasin Article premières lettres 2e niveau
Liste
Cascade Fournisseur Article
Liste
Cascade Fournisseur Article premières lettres
Liste
CascadeTriée NomsPrénoms
Liste
Cascade Triée Diététique
Liste Cascade Biblio
Liste
Cascade Fonction
ListeCascadeArea
Noms de champ
ListeUnites =DECALER(BD!$D$2;;;SOMMEPROD(--(BD!$D$2:$D$6<>"")))
Nom =DECALER(BD!$B$2;;;NBVAL(BD!$B:$B)-1)
unite =DECALER(BD!$A$2;;;NBVAL(BD!$A:$A)-1)
MFC pour vérifier que le nom appartient à l'unité
=NB.SI(DECALER(Nom;EQUIV(G2;unite;0)-1;0;NB.SI(unite;G2));H2)=0
Choix dans une seule cellule (G2)
=SI(NB.SI(ListeUnites;G2)=0;ListeUnites;DECALER(Nom;EQUIV(G2;unite;0)-1;0;NB.SI(unite;G2)))
ListeCascadeTriéeUneCellule
ListeCascadeTriéeUneCellule2
Listes en cascade avec BD 2 niveaux : premières lettres sur 2eme niveau
Le choix sur le 2e niveau se fait en frappant une ou plusieurs lettres.
Liste Cascade 2 niv Premières lettres 2eme niveau
En H2:
-Données/Validation/Liste
=DECALER(Article;EQUIV(G2;Famille;0)-1+EQUIV(H2&"*";DECALER(Article;EQUIV(G2;Famille;0)-1;);0)-1;;NB.SI(DECALER(Article;EQUIV(G2;Famille;0)-1;;NB.SI(Famille;G2));H2&"*"))
Autre exemple
La liste en B4 dépend du choix en A4.
ListeCascadeBD
Sur cet exemple, les listes sont construites à partir d'une BD.
En A4: =ListeProduits
En B4: =DECALER(Couleurs;EQUIV(A4;Produits;0)-1;0;NB.SI(Produits;A4))
Noms de champs
Couleurs =BD!$B$2:$B$30
ListeProduits =DECALER(BD!$E$2;;;NBVAL(BD!$E:$E)-1)
Prix =BD!$C$2:$C$30
Produits =BD!$A$2:$A$30
Maj liste des produits
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([produits], Target) Is Nothing And Target.Count
= 1 Then
[A2:C1000].Sort Key1:=[A2], Key2:=[B2]
[A1:C1000].AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=[E1], Unique:=True
End If
End Sub
Si la BD n'est pas triée
DVCascadeBDnonTrié
DVCascadeBDnonTriéCondition
DVCascadeBDnonTriéConditionFonction
Autre version avec VBA
Il n'est pas obligatoire que la base de données soit triée
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([A2:A10], Target) Is Nothing And Target.Count
= 1 Then
Sheets("liste").[J2] = Empty
Sheets("liste").[A1:C1000].AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("liste").[J1:J2],
CopyToRange:=Sheets("liste").[E1], Unique:=True
End If
If Not Intersect([B2:B10], Target) Is Nothing And Target.Count
= 1 Then
Sheets("liste").[J2] = Target.Offset(0,
-1)
Sheets("liste").[A1:C1000].AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("liste").[J1:K2],
CopyToRange:=Sheets("liste").[F1], Unique:=True
End If
End Sub
Autre version
En H2: =DECALER(Modèle;EQUIV(G2;Type;0)-1;0;EQUIV("*";DECALER(Type;EQUIV(G2;Type;0););0))
DVCascadeBD
DVCascadeBD3nivOPt
DVCascadeBD3nivOPtVBA
En B2:
=DECALER(produit;EQUIV(A2;caté;0)-1;;SI(EQUIV(A2;caté;0)<>EQUIV("zzz";caté);EQUIV("*";DECALER(caté;EQUIV(A2;caté;0)+1;);0)+1;LIGNES(caté)-EQUIV(A2;caté;0)+1))
Listes en cascade avec BD 2 niveaux et image
1- Créer les noms de champ
Charpente =DECALER(Images!$A$2;;;NBVAL(Images!$A:$A)-1)
Pose =DECALER(Images!$B$2;;;NBVAL(Images!$A:$A)-1)
Type_Charpente =DECALER(Images!$E$2;;;NBVAL(Images!$E:$E)-1)
2 - Créer les listes déroulantes en B2 et B3
B2: =Type_charpente
B3: =DECALER(Pose;EQUIV(B2;Charpente;0)-1;0;NB.SI(Charpente;B2))
3-Créer un nom de champ Adr:
Adr =DECALER(Images!$C$2;EQUIV(1;(Charpente=Choix!$B$2)*(Pose=Choix!$B$3);0)-1;0)
4- Sélectionner l'image en B6
5- Dans la zone formule frapper =ADR et valider avec entrée
Listes en cascade BD avec 2 colonnes
On veut sélectionner un produit de remplacement
dans une liste en cascade:
DV
CascadeProdRempl -
La feuille Produits contient:
Créer le nom de champ:
Produits: =DECALER(Produits!$A$2;;;NBVAL(Produits!$A:$A)-1)
Pour obtenir la liste des produits sans doublons:
-Sélectionner F2:F9
=INDEX(Produits;PETITE.VALEUR(SI(EQUIV(Produits;Produits;0)=LIGNE(INDIRECT("1:"&LIGNES(Produits)));
EQUIV(Produits;Produits;0);"");LIGNE(INDIRECT("1:"&LIGNES(Produits)))))
-Valider avec Maj+ctrl+Entrée
Créer les noms de champ:
ListeProduits : =DECALER(Produits!$F$2;;;NB.SI(Produits!$F$2:$F$9;"<>#NOMBRE!"))
Remplacement : =DECALER(Produits!$B$2;;;NBVAL(Produits!$B:$B)-1;3)
Pour créer le menu en cascade:
Données/Validation/Liste
=DECALER(remplacement;EQUIV(B9;Produits;0)-1;0;NB.SI(Produits;B9))
Attention! Il faut d'abord créer
le nom de champ Remplacement avec 1 colonne
=DECALER(Produits!$B$2;;;NBVAL(Produits!$B:$B)-1;1)
-Créer le menu en cascade
-Mettre 3 colonnes dans le nom de champ
Pour empêcher le choix des dates dans le menu du produit de remplacement.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Count = 1 Then
p = Application.Match(Target, Application.Index([Remplacement],
, 1), 0)
If IsError(p) Then
Application.EnableEvents = False
Target = [mémo]
Application.EnableEvents = True
Else
ActiveWorkbook.Names.Add Name:="mémo",
RefersToR1C1:="=" & Chr(34) & Target.Value & Chr(34)
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 3 And Target.Count = 1 Then
ActiveWorkbook.Names.Add Name:="mémo",
RefersToR1C1:="=" & Chr(34) & Target.Value & Chr(34)
End If
End Sub
Liste des noms commençant par la lettre choisie
On choisit d'abord la 1ere lettre puis le nom dans la
même liste
DV Cascade
noms
Données/Validation/Liste
=SI(ET(NBCAR(A2)=1;NB.SI(BDNoms;A2&"*")>0);DECALER(BDNoms;EQUIV(A2&"*";BDNoms;0)-1;;NB.SI(BDNoms;A2&"*"));Lettre)
Liste déroulante intuitive des noms commençant par les premières lettres frappées avec Données/Validation
On frappe les premières lettres avant de cliquer dans la liste. Cette technique est connue sous les noms de saisie semi-automatique, saisie intuitive, autocompletion.
-La liste des noms doit être triée
-Données/Validation/Liste
=DECALER(Noms;EQUIV(A2&"*";Noms;0)-1;;NB.SI(Noms;A2&"*"))
-Dans Alerte erreur décocher Quand les
données non valides sont frappées
DV_Premieres_Lettres
DV_Pays
DV_Motclé_Liste_VBA
Pour empêcher la saisie d'un nom qui n'existe pas dans la liste Noms
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
If Target <> "" Then
On Error Resume Next
Set temp = [noms].Find(Target.Value,
LookAt:=xlWhole)
If Err = 50290 Then Exit Sub
If temp Is Nothing Then Application.Undo
End If
End If
End Sub
Listes en cascade et premières lettres
-Choisir la catégorie en F2
-Frapper la première lettre du nom en G2
-Cliquer dans la liste
=DECALER(Nom;EQUIV(F2;caté;0)-1+EQUIV(G2&"*";DECALER(Nom;EQUIV(F2;caté;0)-1;);0)-1;;
NB.SI(DECALER(Nom;EQUIV(F2;caté;0)-1;;NB.SI(caté;F2));G2&"*"))
CascadePremièresLettres
CascadePremièresLettresAliment
CascadePremièresLettresArticle
CascadePremièresLettresProduit
Autre exemple
L'opérateur frappe la première lettre du produit pour obtenir la liste des produits commençant par la lettre choisie.
1ere liste en B2: Données/Validation/Liste:
=DECALER(Choix1;;EQUIV(B2&"*";Choix1;0)-1;;NB.SI(Choix1;B2&"*"))
2eme liste enC2: Données/Validation/Liste:
=DECALER(DECALER(Choix2;;EQUIV(B2;Choix1;0)-1);EQUIV(C2&"*";DECALER(Choix2;;
EQUIV(B2;Choix1;0)-1);0)-1;; NB.SI(DECALER(Choix2;;EQUIV(B2;Choix1;0)-1);C2&"*"))
Autre exemple
L'opérateur frappe la première lettre du produit pour obtenir la liste des produits commençant par la lettre choisie.
Pour des nombres, formatter la colonne en texte
Choix dans une liste de validation en frappant les premières lettres d'un mot d'un élément d'une liste
Le but est de choisir une activité dans une liste
de validation :
-en frappant les premières lettres d'un mot d'une activité,
-puis en cliquant sur la flèche, on obtient la liste des activités
contenant le mot commençant par les lettres frappées.
Problème: Pour chaque élément de liste, il y a plusieurs mots
Pour choisir agnès + kiné (br),
on peut frapper ag ou ki
pour choisir françoise + kiné (ca),on peut
frapper fr ou ki
pour choisir marie-rose + pain (ca), on peut frapper
ma ou pa
Noms contenant les lettres frappées avec Données/Validation (saisie semi-automatique)
On cherche les noms contenant ar
-En E2, frapper des lettres contenues dans les noms cherchés
-Cliquer sur la flèche
En C2: =INDEX(A:A;MIN(SI(ESTNUM(CHERCHE($E$2;champ));SI(NB.SI(C$1:C1;champ)=0;LIGNE(champ)))))
Valider avec maj+ctrl+entrée
S'il y a plusieurs menus déroulants, il faut une liste par menu.
DVLettresContenues
DVLettresContenues
dernier
DVLettresContenues
plusieurs
Sur cette version, les listes sont recopiables
DVLettresContenuesVBA
DVLettresContenuesVBA2
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([A2:A10], Target) Is Nothing And Target.Count
= 1 Then
If IsError(Application.Match(Target, [noms], 0))
Then
Set d = CreateObject("Scripting.Dictionary")
For Each c In [noms]
If InStr(UCase(c.Value),
UCase(Target)) > 0 Then d(c.Value) = ""
Next
Target.Validation.Delete
If d.Count > 0 Then
Target.Validation.Add
xlValidateList, Formula1:=Join(d.keys, ",")
Target.Validation.ShowError
= False
Target.Select
SendKeys "%{down}"
End If
End If
End If
Liste déroulante intuitive des noms commençant par les premières lettres frappées (comme sur 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.
Pour obtenir la liste complète des noms faire un
double-clic.
La propriété MacthEntry doit être
positionée sur FrmMatchEntryNone
Liste
Déroulante Intuitive TableurPrem Lettres
Liste
Déroulante Intuitive Google
Private Sub ComboBox1_GotFocus()
ComboBox1.List = Sheets("BD").Range("liste").Value
End Sub
Private Sub ComboBox1_Change()
If Me.ComboBox1 <> "" Then
Set d1 = CreateObject("Scripting.Dictionary")
clé = UCase(Me.ComboBox1) & "*"
For Each c In Sheets("BD").[Liste]
If UCase(c) Like clé 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.
La propriété MatchEntry du ComboBox doit
être positionnée sur FrmMatchEntryNone.
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 Tableau
Liste
déroulante Intuitive Tableur Multiple 2
Liste
déroulante Intuitive récupération mise forme
Liste
déroulante Intuitive Tableur 2 colonnes
Liste
déroulante Intuitive Tableur Multi-Listes
Liste
déroulante Intuitive Tableur Multi-lignes
Liste
déroulante Intuitive Tableur Multiple Accent
Liste déroulante
Intuitive Tableur CP Ville
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
Dictionnaire
Fonctions Français Anglais
Saisie intuitive
rue
Recherche
intuitive & positionnement
Recherche
intuitive code postal & ville
Recherche
intuitive code postal & ville 2
Recherche
intuitive avec 2 colonnes
Recherche intuitive
avec 3 colonnes
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 = a
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
'If Target <> "" Then SendKeys
"{esc}"
'Me.ComboBox1.DropDown ' ouverture automatique
au clic dans la cellule (optionel)
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
Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Me.ComboBox1.List = a
Me.ComboBox1.Activate
Me.ComboBox1.DropDown
End Sub
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger,
ByVal Shift As Integer)
If KeyCode = 13 Then ActiveCell.Offset(1).Select
End Sub
Liste
déroulante intuitive 2 niveaux
Liste
déroulante intuitive 3 niveaux
Liste
déroulante intuitive Form 3 niveaux TAB
Liste
déroulante intuitive 3 niveaux PC MAC
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é MatchEntry doit être positionnée sur FrmMatchEntryNone.
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 Touche Entrée
Liste
Déroulante Intuitive auto-sélection
ComparaisonTextBox/ListBox
Intuitive 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 Filter Classeur Fermé
Liste
Déroulante Intuitive Form Contenu Filter Info
Liste
Déroulante Intuitive Form Contenu Filter Info Ajout
Recherche
Intuitive Form Contenu Filter Pos curseur
Liste
Déroulante Intuitive lettres Form
Liste
Déroulante Intuitive Form Villes
Liste
Intuitive formulaire 2 colonnes
Liste Intuitive
formulaire 2 colonnes Bis
Liste
Intuitive formulaire 2 colonnes 2
Liste Intuitive
formulaire 3 colonnes
Liste Intuitive
formulaire 3 colonnes 2
Liste
Intuitive cellule multi-lignes
Liste
Intuitive formulaire 2 niveaux 2 colonnes
Devis
Intuitif 3 colonnes
Devis Intuitif
3 colonnes 2 choix
Liste
Intuitive formulaire 2 colonnes trié
Liste
déroulante intuitive Form 3 niveaux PC MAC
Liste
déroulante intuitive Classeur fermé
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 = a
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
Recherche BD avec ComboBox intuitif
La liste du combobox se réduit au fur et à mesure de la frappe des caractères.
Filtre
noms combobox intuitif
Choix noms/prénoms
combobox intuitif
Option Compare Text
Dim choix()
Private Sub ComboBox1_GotFocus()
Set f = Sheets("bd")
choix = Application.Transpose(f.Range("A2:A" &
f.[A65000].End(xlUp).Row).Value)
Me.ComboBox1.List = choix
End Sub
Private Sub ComboBox1_Change()
[G2] = Me.ComboBox1
If [G2] = "" Then [G2] = " "
Me.ComboBox1.List = Filter(choix, [G2], True, vbTextCompare)
Me.ComboBox1.DropDown
Sheets("BD").Range("A1:J10000").AdvancedFilter
Action:= _
xlFilterCopy, CriteriaRange:=[G1:G2], CopyToRange:=[A5:J5]
End Sub
Autres exemples
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 ComboBox 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
Saisie intuitive caractère par caractère sur le 1er choix, 2eme Choix et 3eme choix
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
AutoCompletion avec comboBox
En frappant la ou les première(s) lettre(s), on voit apparaître le premier mot commençant par les lettres frappées. C'est un ComboBox qui permet d'obtenir cette autocompletion. La propriété MatchEntry du Combobox est positionnée sur FrmMatchEntryComplete.
AutoCompletion
AutoCompletion
3 niveaux
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 = a
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
Else
Me.ComboBox1.Visible = False
End If
End Sub
Private Sub ComboBox1_Change()
ActiveCell.Value = Me.ComboBox1
End Sub
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger,
ByVal Shift As Integer)
If KeyCode = 13 Then ActiveCell.Offset(1).Select
End Sub
Code Postal
DV Code
Postal
DV Code Postal Form
DV Départment
Code Postal
Régions
Départements
Communes Code postal sans
formulaire
L'opérateur choisit le code postal en A2 puis la ville en B2
En B2:=DECALER(Ville1;EQUIV(A2;cpost1;0)-1;0;NB.SI(cpost1;A2))
Choix par ville
-L'opérateur frappe les premières lettres
de la ville
-Puis clique sur la flèche
Choix du code postal ou de la ville en premier
DV Code
Postal 3
Form Code Postal
DVCodePostal
DVCodePostal2
Au départ, A2 et B2 sont vides
Cas1: Choix du code postal en premier
1- L'opérateur choisit le code postal en A2
2- L'opérateur choisit la ville en B2
Cas2: Choix de la ville en premier
1- L'opérateur frappe la(les) première(s)
lettre(s) de la ville en B2 puis choisit la ville
2- L'opérateur choisit le code postal en A2
En A2: =SI(B2="";ListeCP;DECALER(cpost2;EQUIV(B2;ville2;0)-1;0;1))
En B2: =SI(A2<>"";DECALER(Ville1;EQUIV(A2;cpost1;0)-1;0;NB.SI(cpost1;A2));
DECALER(ville2;EQUIV(B2&"*";ville2;0)-1;;NB.SI(ville2;B2&"*")))
Code postal et ville sont réunis dans la même cellule
- L'opérateur frappe les premiers caractères
du code postal
- puis clique sur la flèche
=DECALER(CPVILLE;EQUIV(B2&"*";CPVILLE;0)-1;0;NB.SI(CPVILLE;B2&"*"))
Choix par code ou par ville
1- L'opérateur choisit X en A2 s'il veut choisir
par ville
2- L'opérateur frappe les premiers caractères du code postal
ou de la ville
3- puis clique sur la flèche
=SI(A2<>"x";DECALER(CPVILLE;EQUIV(B2&"*";CPVILLE;0)-1;0;NB.SI(CPVILLE;B2&"*"));
DECALER(VilleCP;EQUIV(B2&"*";STXT(VilleCP;7;99);0)-1;0;SOMMEPROD(--(STXT(VilleCP;7;NBCAR(B2))=B2))))
Choix Département -> Code postal -> Ville avec formulaire
Listes en cascade dans un formulaire
Dim f
Private Sub UserForm_Initialize()
Set f = Sheets("bd")
Set mondico = CreateObject("Scripting.Dictionary")
For Each c In f.Range("b2:b" & f.[B65000].End(xlUp).Row)
mondico(c.Value) = ""
Next c
Me.ComboBox1.AddItem "(tous)"
For Each c In mondico.keys
Me.ComboBox1.AddItem c
Next c
Me.ComboBox1.ListIndex = 0
End Sub
Private Sub ComboBox1_Change()
Me.ComboBox2.Clear
For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
If c.Offset(0, 1) = Me.ComboBox1 Or Me.ComboBox1
= "(tous)" Then
Me.ComboBox2.AddItem c
End If
Next c
End Sub
Private Sub ComboBox2_Change()
ActiveCell = Me.ComboBox2
Unload Me
End Sub
Autre exemple
Un client a plusieurs adresses.
L'opérateur choisit le client et l'adresse dans un formulaire.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$B$2" Then
UserForm1.Show
End If
End Sub
Private Sub UserForm_Initialize()
Set f = Sheets("BD")
Set MonDico = CreateObject("Scripting.Dictionary")
For Each c In Range(f.[A2], f.[A65000].End(xlUp))
If c.Value <> "" Then MonDico.Item(c.Value)
= c.Value
Next c
Me.ComboBox1.List = MonDico.items
SendKeys "{F4}"
End Sub
Private Sub ComboBox1_Change()
Set f = Sheets("BD")
i = 0
Me.ComboBox2.Clear
For Each c In Range(f.[A2], f.[A65000].End(xlUp))
If c = Me.ComboBox1 Then
Me.ComboBox2.AddItem
Me.ComboBox2.List(i, 0) = c.Offset(,
1).Value
Me.ComboBox2.List(i, 1) = c.Offset(0,
2).Value
Me.ComboBox2.List(i, 2) = c.Offset(0,
3).Value
i = i + 1
End If
Next c
Me.ComboBox2.SetFocus
SendKeys "{F4}"
End Sub
Private Sub ComboBox2_Change()
If Me.ComboBox2.ListIndex > -1 Then
ActiveCell = Me.ComboBox1
ActiveCell.Offset(2) = Me.ComboBox2
ActiveCell.Offset(3) = Me.ComboBox2.Column(1)
ActiveCell.Offset(4) = Me.ComboBox2.Column(2)
ActiveCell.Offset(5) = Me.ComboBox2.Column(3)
End If
Unload Me
End Sub
Facture avec formulaire
FactureCascade
FactureCascade2
Liste avec filtre
On filtre les noms d'un service (C2)
=DECALER(Liste;EQUIV(C2;Filtre;0)-1;;NB.SI(Filtre;C2))
Liste des lignes filtrées d'un filtre automatique
En A2:
=SI(LIGNES($1:1)<=SOUS.TOTAL(3;Nom);
INDEX(Nom;PETITE.VALEUR(SI(SOUS.TOTAL(3;INDIRECT("A"&LIGNE(Nom)))=1;LIGNE(INDIRECT("1:"&LIGNES(Nom))));LIGNES($1:1)));0)
Valider avec Maj+ctrl+entrée
Choix multiples dans un menu:les choix s'ajoutent
Les choix s'ajoutent ou se retranchent si choix déjà fait.
DV ChoixSuccessifs - DV ChoixSuccessifs2
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$2" And Target.Count = 1
Then
Application.EnableEvents = False
ValSaisie = Target
Application.Undo
p = InStr(Target, ValSaisie)
If p > 0 Then
Target = Left(Target, p - 1)
& Mid(Target, p + Len(ValSaisie) + 1)
If Right(Target, 1) = ":"
Then
Target = Left(Target,
Len(Target) - 1)
End If
Else
If Target = "" Then
Target = ValSaisie
Else
Target = Target &
":" & ValSaisie
End If
End If
Application.EnableEvents = True
End If
End Sub
En remplaçant ':' par chr(10), l'affichage des noms se fait en colonne.
Premières lettres + choix multiples
-On peut frapper les premières lettres puis cliquer
dans la liste
-Les choix s'ajoutent ou se retranchent
DVPremiereLettresChoixSuccessifs
DVPremiereLettresChoixSuccessif2
Données/Validation/Liste
=DECALER(LesNoms;EQUIV(C2&"*";LesNoms;0)-1;;NB.SI(LesNoms;C2&"*"))
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$2" And Target.Count = 1
Then
On Error Resume Next
Set temp = Sheets("Listes").Range("LesNoms").Find(what:=Target.Value,
LookAt:=xlWhole)
If Err = 0 Then
On Error GoTo 0
Set temp =Sheets("Listes").Range("LesNoms").Find(what:=Target.Value,
LookAt:=xlWhole)
If temp Is Nothing Then Exit Sub
p = InStr(Target.Offset(0,
2), Target.Value & ":")
If p > 0 Then
Target.Offset(0,
2) = Left(Target.Offset(0, 2), p - 1) & _
Mid(Target.Offset(0,
2), p + Len(Target.Value) + 1)
Else
Target.Offset(0,
2) = Target.Offset(0, 2) & Target.Value & ":"
End If
Application.EnableEvents
= False
Target = Empty
Application.EnableEvents
= True
End If
End If
End Sub
Choix multiples avec ListBox
DVChoix
Régions ListBox
DV
Choix Remarques ListBox Options
DV Choix
Remarques ListBox Options 2
DV Choix Régions
Form
DV
Choix Multiples Form
DV
Choix 2 niveaux ListBox Options
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([A2:A10], Target) Is Nothing Then
Me.ListBox1.MultiSelect = fmMultiSelectMulti
Me.ListBox1.List = Sheets("BD").Range("A2:A28").Value
a = Split(Target, " ")
If UBound(a) >= 0 Then
For i = 0 To Me.ListBox1.ListCount
- 1
If Not IsError(Application.Match(Me.ListBox1.List(i),
a, 0)) Then Me.ListBox1.Selected(i) = True
Next i
End If
Me.ListBox1.Height = 150
Me.ListBox1.Width = 100
Me.ListBox1.Top = Target.Top
Me.ListBox1.Left = Target.Left + Target.Width
Me.ListBox1.Visible = True
Else
Me.ListBox1.Visible = False
End If
End Sub
Private Sub ListBox1_Change()
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then temp =
temp & Me.ListBox1.List(i) & " "
Next i
ActiveCell = Trim(temp)
End Sub
Liste cascade BD 2 & 3 niveaux avec VBA
Liste
cascade 2niv VBA
Liste cascade 2niv
VBA 2
Liste cascade
3 niv VBA 3
Liste cascade
Pays Produit
Liste cascade
Date ID
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([a2:A1000], Target) Is Nothing And Target.Count
= 1 Then
Set f = Sheets("listes")
Set d = CreateObject("Scripting.Dictionary")
For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row):
d(c.Value) = "": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Join(d.keys,
",")
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([a2:A1000], Target) Is Nothing And Target.Count
= 1 Then
If Target <> "" Then
Set f = Sheets("listes")
Set d = CreateObject("Scripting.Dictionary")
For Each c In f.Range("a2:a"
& f.[a65000].End(xlUp).Row)
If c.Value
= Target Then d(c.Offset(, 1)) = ""
Next c
Target.Offset(, 1).Validation.Delete
Target.Offset(, 1).Validation.Add
xlValidateList, Formula1:=Join(d.keys, ",")
a = d.keys: Target.Offset(,
1) = a(0)
If d.Count > 1 Then Target.Offset(,
1).Select: SendKeys "%{down}"
Else
Target.Offset(, 1) = ""
End If
End If
End Sub
Avec le filtre élaboré
Noms de champ
Choix1 =DECALER(BD!$D$2;;;NBVAL(BD!$D:$D)-1)
Choix2 =DECALER(BD!$E$2;;;NBVAL(BD!$E:$E)-1)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([A2:A10], Target) Is Nothing And Target.Count
= 1 Then
Sheets("BD").[g2] = ""
Sheets("BD").[A1:B1000].AdvancedFilter
Action:=xlFilterCopy, _
CopyToRange:=Sheets("BD").[D1],
Unique:=True
End If
If Not Intersect([b2:b10], Target) Is Nothing And Target.Count = 1 Then
Sheets("BD").[g2] = Target.Offset(,
-1)
Sheets("BD").[A1:B1000].AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("bd").[g1:g2],
CopyToRange:=Sheets("BD").[E1]
End If
End Sub
Liste cascade BD X niveaux VBA
Le nombre de niveaux est paramétré.
Cascade
x niveaux horizontal
Cascade
x niveaux horizontal liste longue
Cascade
x niveaux vertical
Cascade
x niveaux dans une cellule
Cascade
2 niveaux horizontal 3
Dim zSaisie, NbNiv
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set zSaisie = Range("B2:G4")
NbNiv = 6
If Not Intersect(zSaisie, Target) Is Nothing And Target.Count
= 1 Then
TblBD = [Tableau1].Value
Set d1 = CreateObject("Scripting.Dictionary")
nivCourant = Target.Column - zSaisie.Column +
1
Dim Tmp(): ReDim Tmp(1 To nivCourant)
For k = 1 To nivCourant - 1
Tmp(k) = Target.Offset(, -(nivCourant
- k))
Next k
For i = 1 To UBound(TblBD)
témoin = True
For k = 1 To nivCourant
- 1
If TblBD(i,
k) <> Tmp(k) Then témoin = False: Exit For
Next k
If témoin Then
d1(TblBD(i, nivCourant)) = ""
Next i
If d1.Count > 0 Then
temp = Join(d1.keys, ",")
Target.Validation.Delete
If temp <>
"" Then Target.Validation.Add xlValidateList, Formula1:=temp
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(zSaisie, Target) Is Nothing And Target.Count
= 1 Then
nivCourant = Target.Column - zSaisie.Column +
1
If nivCourant < NbNiv Then
Application.EnableEvents = False
Target.Offset(, 1).Resize(, NbNiv
- nivCourant).Validation.Delete
Target.Offset(, 1).Resize(, NbNiv
- nivCourant) = ""
Application.EnableEvents = True
End If
End If
End Sub
Liste cascade BD X niveaux indentation
Les niveaux sont basés sur l'indentation en colonne A. Le nombre de niveaux est paramétré
Cascade
x niveaux indentation horizontal
Cascade
x niveaux indentation une cellule
Cascade
x niveaux indentation horizontal 2
Genère
indentation à partir d'une BD
Genère
BD à partir d'une indentationl
Liste cascade BD 3 niveaux avec VBA
Il n'est pas obligatoire que la base de données soit triée.
ListeCascadeBD3niveaux
ListeCascadeBD3niveauxb
ListeCascadeBD3niveauxc
ListeCascadeBD3niveaux
Devis
ListeCascadeBD3niveauxFormPrix
Noms de champ à créer
Choix1 =DECALER(BD!$G$2;;;NBVAL(BD!$G:$G)-1)
Choix2 =DECALER(BD!$H$2;;;NBVAL(BD!$H:$H)-1)
choix3 =DECALER(BD!$I$2;;;NBVAL(BD!$I:$I)-1)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
Set f = Sheets("BD")
If Not Intersect([A2:A30], Target) Is Nothing And Target.Count
= 1 Then
f.[N2] = Empty
f.[A1:D1000].AdvancedFilter Action:=xlFilterCopy,
_
CriteriaRange:=f.[N1:N2], CopyToRange:=f.[G1],
Unique:=True
End If
If Not Intersect([B2:B30], Target) Is Nothing And Target.Count
= 1 Then
f.[N2] = Target.Offset(0, -1)
f.[O2] = Empty
f.[A1:D1000].AdvancedFilter Action:=xlFilterCopy,
_
CriteriaRange:=f.[N1:O2], CopyToRange:=f.[H1],
Unique:=True
End If
If Not Intersect([C2:C30], Target) Is Nothing And Target.Count
= 1 Then
f.[N2] = Target.Offset(0, -2)
f.[O2] = Target.Offset(0, -1)
f.[p2] = Empty
f.[A1:D1000].AdvancedFilter Action:=xlFilterCopy,
_
CriteriaRange:=f.[N1:P2], CopyToRange:=f.[I1],
Unique:=True
End If
End Sub
Lors du choix d'un élément, si on veut un positionnement sur le premier élément de la liste de niveau inférieur:
'positionnement sur le premier élément
(option)
Private Sub Worksheet_Change(ByVal Target As Range) ' positionnement sur
premier élément
Set f = Sheets("BD")
Application.EnableEvents = False
If Not Intersect([A2:A30], Target) Is Nothing And Target.Count
= 1 Then
f.[N2] = Target
f.[O2] = Empty
f.[A1:D1000].AdvancedFilter Action:=xlFilterCopy,
_
CriteriaRange:=f.[N1:O2], CopyToRange:=f.[H1],
Unique:=True
Target.Offset(0, 1) = f.Range("choix2")(1)
End If
If Not Intersect([B2:B30], Target) Is Nothing And Target.Count
= 1 Then
f.[N2] = Target.Offset(0, -1)
f.[O2] = Target
f.[p2] = Empty
f.[A1:D1000].AdvancedFilter Action:=xlFilterCopy,
_
CriteriaRange:=f.[N1:P2], CopyToRange:=f.[I1],
Unique:=True
Target.Offset(0, 1) = f.Range("choix3")(1)
End If
Application.EnableEvents = True
End Sub
Avec formulaires
DVCascade3NiveauxFormulaire
ListeCascadeBD3niveauxFormPrix
Liste cascade BD 4 niveaux avec VBA
DV
Cascades 4 niv BD Hôtel
DV
Cascades 4 niv BD Hôtel Formulaire
Form4niveauxRayonTypeCatéArticle
DV
Cascades 4 niv BD
DV
Cascades 4 niv BDIsolation
DV Cascades
5 niv BD
DV Cascades
6 niv BD
DV Cascades
6 niv BDBis
Liste cascade BD imcomplète 3&4 niveaux avec VBA
DV
Cascades 3 niv BD Incomplète
DV
Cascades 3 niv BD Incomplète Bis
DV
Cascades 3 niv BD Incomplète Continent Pays Ville
DV
Cascades 4 niv BD Incomplète Hôtel
DV
Cascades 4 niv BD Incomplète
DV
Cascades 4 niv BD Incomplète Horiz
DV
Cascades 4 niv BD Incomplète Vert Prix
Autre exemple
Liste cascade BD (plan comptable) 5 niveaux avec VBA
DVPlanComptable
DVPlanComptableForm
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([A2:A10], Target) Is Nothing Then
Set d = CreateObject("scripting.dictionary")
For Each c In Application.Index([bd], , 1)
If c <> "" Then
temp = c.Value & c.Offset(,
6).Value
d(temp) = ""
End If
Next c
Sheets("bd").[J2].Resize(d.Count) =
Application.Transpose(d.keys)
End If
'--
If Not Intersect([B2:E10], Target) Is Nothing And Target.Count = 1 Then
col = Target.Column
Sheets("bd").Cells(2, "k").Resize(100).ClearContents
If Target.Offset(, -1) <> "" Then
Set d = CreateObject("scripting.dictionary")
For Each c In Application.Index([bd], , col)
If c.Value <> "" Then
If Left(c, col - 1) =
Left(Target.Offset(, -1), col - 1) Then
temp = c.Value
& c.Offset(, 7 - col).Value
d(temp) =
""
End If
End If
Next c
If d.Count > 0 Then Sheets("bd").Cells(2,
"k").Resize(d.Count) = Application.Transpose(d.keys)
End If
End If
End Sub
Menus en cascade avec 3 - 4 - 5 - 6 -7 niveaux
Attention!
-pour Excel 2000, la longueur des listes doit être inférieure
à 200 caractères.
-pour Excel 2007, la longueur des listes doit être inférieure
à 8000 caractères.
ListeCascade
3 niv Inf 200
ListeCascade
3 niv Inf 200 Une Cellule
ListeCascade
3 nivInf 200 Choix Interchangeable
Liste
Cascade 3 niv Inf 8000
Liste Cascade 3
niv Inf 8000_2
Liste Cascade 4
niv Inf 8000
Liste Cascade
4 niv Inf 8000_2
Liste Cascade
4 niv Devis Inf 8000
Liste
Cascade 5 niv Horiz Inf 8000
Liste Cascade
5 niv Horiz Inf 8000 Prix
Liste
Cascade 5 niv Inf 8000 vertical PC+MAC
Liste Cascade
6 niv Devis Inf 8000
Liste Cascade
7niv vertical Inf 8000
Nom de champ à créer
MaBD =DECALER(BD!$A$2;;;NBVAL(BD!$A:$A)-1;3)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column <= 3 Then
Set mondico = CreateObject("Scripting.Dictionary")
Select Case Target.Column
Case 1
For Each c
In Application.Index([MaBD], , 1)
If
Not mondico.Exists(c.Value) Then mondico.Add c.Value, c.Value
Next c
Case 2
For Each c
In Application.Index([MaBD], , 2)
If
Not mondico.Exists(c.Value) And c.Offset(0, -1) = Target.Offset(0, -1)
Then mondico.Add c.Value, c.Value
Next c
Case 3
For Each c
In Application.Index([MaBD], , 3)
If
Not mondico.Exists(c.Value) And _
c.Offset(0,
-1) = Target.Offset(0, -1) And _
c.Offset(0,
-2) = Target.Offset(0, -2) Then mondico.Add c.Value, c.Value
Next c
End Select
If mondico.Count > 0 Then
For Each c In mondico.items:
temp = temp & c & ",": Next c
Target.Validation.Delete
Target.Validation.Add
xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End If
End Sub
Cascade BD 3 niveaux avec formules
A - Il n'y a qu'une liste de choix
a/ Le même modèle n'existe pas dans 2 marques différentes
En E2:
=INDEX(MARQUE;MIN(SI(MARQUE<>"";SI(NB.SI(E$1:E1;MARQUE)=0;LIGNE(INDIRECT("1:"&LIGNES(MARQUE)));LIGNES(MARQUE)))))
En F2:
=INDEX(Modele;MIN(SI(MARQUE=ChoixMarque;SI(NB.SI(F$1:F1;Modele)=0;LIGNE(INDIRECT("1:"&LIGNES(Modele)));LIGNES(Modele)))))
Liste de validation du 3e Niveau:
=DECALER(couleur;EQUIV(B2;modele;0)-1;;NB.SI(modele;B2))
DV
Cascades 3 niv BD 1 seul choix
DV
Cascades 3 niv BD 1 seul choix2
Noms de champ
ChoixMarque =Choix!$B$1
Couleur =DECALER(BD!$C$2;;;NBVAL(BD!$C:$C))
ListeMarques =DECALER(BD!$E$2;;;NB.SI(BD!$E$2:$E$8;"<>0"))
ListeModeles =DECALER(BD!$F$2;;;NB.SI(BD!$F$2:$F$8;"<>0"))
MARQUE =DECALER(BD!$A$2;;;NBVAL(BD!$A:$A))
Modele =DECALER(BD!$B$2;;;NBVAL(BD!$B:$B))
b/ Si le même modèle (choix2) existe dans 2 marques différentes (choix1)
DV
Cascades 3 niv BD 1 seul choix
DV Cascades
3 niv BD 1 seul choix2
B -Il y a plusieurs listes de choix
a - La même référence (choix2) ne doit pas exister dans 2 marques différentes(choix1)
DV
Cascades 3 niv BD
DV
Cascades 3 niv BDProduits
DV Cascades
3 niv BD2
1ere liste: =ListeMarque
2e liste: =DECALER(Modèle2;EQUIV(A2;Marque2;0)-1;0;NB.SI(Marque2;A2))
3e liste: =DECALER(Couleur;EQUIV(B2;Modèle;0)-1;;NB.SI(Modèle;B2))
Noms de champ à créer
Couleur =DECALER(BD!$C$2;;;NBVAL(BD!$A:$A)-1)
ListeMarques =DECALER(BD!$F$2;;;NBVAL(BD!$F:$F)-1)
Marque =DECALER(BD!$A$2;;;NBVAL(BD!$A:$A)-1)
Modèle =DECALER(BD!$B$2;;;NBVAL(BD!$A:$A)-1)
Modèle2 =DECALER(BD!$I$2;;;NBVAL(BD!$I:$I)-1)
Prix =DECALER(BD!$D$2;;;NBVAL(BD!$D:$D)-1)
Marque2 =DECALER(BD!$H$2;;;NBVAL(BD!$H:$H)-1)
b - Le même produit (choix2) existe dans 2 marques différentes (choix1)
DV
Cascades 3 niv Formules BD
DV
Cascades 3 niv Formules BD budget Familial
DV
Cascades 3 niv Formules BD Prix
DV
Cascades 3 niv Formules BD PrixTemps
DV
Cascades 3 niv Formules BD Contact
DV
Cascades 3 niv Formules Lavage
DV
Cascades 3 niv Fonction VBA
DV
Cascades 3 niv Form BD Prix
1ere liste:
=Choix1
2e liste:
=DECALER(ColChoix2;EQUIV(A2;ColChoix1;0)-1;0;NB.SI(ColChoix1;A2))
3e liste:
=DECALER(Choix3BD;EQUIV(A2;Choix1Bd;0)-1+ EQUIV(B2;DECALER(Choix2Bd;EQUIV(A2;Choix1Bd;0)-1;);0)-1;0;SOMMEPROD((Choix1Bd=A2)*(Choix2Bd=B2)))
Le prix s'obtient avec :=SI(A2<>"";INDEX(Prix;EQUIV(1;(Choix1BD=A2)*(Choix2BD=B2)*(Choix3BD=C2);0));"")
Autre exemple
On veut choisir un type de papier, le grammage et la largeur.
DVCascade3Niveaux
DVCascade3Niveaux2
En E2:
=INDEX(Type;MIN(SI(Type<>"";SI(NB.SI(E$1:E1;Type)=0;LIGNE(INDIRECT("1:"&LIGNES(Type)));LIGNES(Type)))))
Valider avec Maj+ctrl+entrée
En F2:
=SI(LIGNES($1:1)<=NB(1/FREQUENCE(SI(Type=$A$3;Gramme);Gramme));
INDEX(Gramme;MIN(SI(Gramme<>"";SI((NB.SI(F$1:F1;Gramme)=0)*(Type=A$3);LIGNE(INDIRECT("1:"&LIGNES(Gramme)))))));0)
Données/Validation en C3:
=DECALER(largeur;EQUIV(A3;Type;0)-1+ EQUIV(B3;DECALER(Gramme;EQUIV(A3;Type;0)-1;);0)-1;0;SOMMEPROD((Type=A3)*(Gramme=B3)))
Noms de champ
Gramme =BD!$B$2:$B$100
largeur =BD!$C$2:$C$100
Type =BD!$A$2:$A$100
Choix d'un appareil en fonction du type de panneau et du nombre de panneaux
=DECALER(TypeApp;EQUIV(C2;TypePan;0)-1+EQUIV(C7;DECALER(NbPan;
EQUIV(C2;TypePan;0)-1;);0)-1;0;SOMMEPROD((TypePan=C2)*(NbPan=C7)))
Noms de champ
ListePan =DECALER($A$2;;;NBVAL($A$2:$A$6))
NbPan =$B$13:$B$60
TypeApp =$C$13:$C$60
TypePan =$A$13:$A$60
Liste cascade 3 niveaux BD formules avec onglets
Les véhicules de chaque marque sont sous forme de BD (Un onglet pour chaque marque)
DV3nivOnglet
DV3nivOngletMatelas
DV3niv
Onglet Fournisseur
DV3niv
Onglet Stations Météo
Marque: =Marques
Modèle: =DECALER(INDIRECT("'"&A2&"'!A2");;;NB.SI(INDIRECT("'"&A2&"'!$A2:$A15");"<>0"))
Couleur:=DECALER(INDIRECT("'"&A2&"'!d2:d100");EQUIV(B2;INDIRECT("'"&A2&"'!c2:c100");0)-1;0;NB.SI(INDIRECT("'"&A2&"'!c2:c100");B2))
Pur obtenir les noms des onglets automatiquement
DV3nivOngletNomsOngletsAutomatique
DV3nivOngletMatelasNomsOngletsAutomatique
Menus en cascade avec formulaire
MenuCascade3nivForm
MenuCascade3nivForm1cellule
Code formulaire
Private Sub UserForm_Initialize()
Set MonDico = CreateObject("Scripting.Dictionary")
For Each c In [choix1]
If Not MonDico.Exists(c.Value) Then MonDico.Add
c.Value, c.Value
Next c
Me.ComboBox1.List = MonDico.items
If ActiveCell <> "" Then Me.ComboBox1.Value
= ActiveCell.Value
If ActiveCell.Offset(0, 1) <> "" Then Me.ComboBox2.Value
= ActiveCell.Offset(0, 1).Value
If ActiveCell.Offset(0, 2) <> "" Then Me.ComboBox3.Value
= ActiveCell.Offset(0, 2).Value
Me.Left = ActiveCell.Left
Me.Top = ActiveCell.Top + 60
End Sub
Private Sub ComboBox1_Change()
Set MonDico = CreateObject("Scripting.Dictionary")
For Each c In [choix2]
If c.Offset(0, -1) = Me.ComboBox1 Then
If Not MonDico.Exists(c.Value) Then
MonDico.Add c.Value, c.Value
End If
Next c
Me.ComboBox2.List = MonDico.items
Me.ComboBox2.ListIndex = 0
End Sub
Private Sub ComboBox2_Change()
Set MonDico = CreateObject("Scripting.Dictionary")
For Each c In [choix3]
If c.Offset(0, -1) = Me.ComboBox2 And c.Offset(0,
-2) = Me.ComboBox1 Then
If Not MonDico.Exists(c.Value)
Then MonDico.Add c.Value, c.Value
End If
Next c
Me.ComboBox3.List = MonDico.items
Me.ComboBox3.ListIndex = 0
End Sub
Private Sub B_ok_Click()
ActiveCell = Me.ComboBox1
ActiveCell.Offset(0, 1) = Me.ComboBox2
ActiveCell.Offset(0, 2) = Me.ComboBox3
Unload Me
End Sub
Code feuille
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As
Range, Cancel As Boolean)
If Target.Column = 1 Then
UserForm1.Show
End If
Cancel = True
End Sub
Items dans une colonne et choix dans une cellule
Noms de champ
Caté =DECALER(Feuil1!$C$2;;;NB.SI(Feuil1!$C$2:$C$16;"~**"))
Items =DECALER(Feuil1!$A$2;;;NBVAL(Feuil1!$A:$A)-1)
Données/Validation/Liste
=SI(GAUCHE(E2;3)<>"***";DECALER(Caté;;;NBVAL(Caté)-1);DECALER(Items;EQUIV(E2;Items;0);;EQUIV(INDEX(Caté;EQUIV(E2;Caté;0)+1);Items;0)-EQUIV(E2;Items;0)-1))
ItemsUneColonne
ItemsUneColonne2
ItemsUneColonneDevis
ItemsUneColonneDevis2
CommandeMobilier
La liste des catégories peut être obtenue à partir de la première par formule matricielle:
En C2:
=SI(LIGNES($1:1)<=NB.SI(Items;"~*~*~**");
INDEX(Items;PETITE.VALEUR(SI(GAUCHE(Items;3)="***";LIGNE(INDIRECT("1:"&LIGNES(Items))));LIGNES($1:1)));"")
Code postal (plusieurs villes)
-L'opérateur frappe le code postal.
-S'il y a plusieurs villes --> choix de la ville
=DECALER(CP;EQUIV($A$2;CP;0)-1;1;NB.SI(CP;$A$2))
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
Target.Offset(0, 1) = Empty
n = Application.CountIf([CP], Target)
Select Case n
Case 1
Target.Offset(0, 1) =
[CP].Find(Target, LookAt:=xlWhole).Offset(0, 1)
Case Is > 1
Target.Offset(0, 1).Select
SendKeys "%{down}"
End Select
End If
End Sub
Choix du prénom pour un nom
-L'opérateur choisit un nom en A2.
-S'il y a plusieurs prénoms pour le nom --> choix du prénom
en B2
Liste des noms en I2:
=INDEX(Noms;MIN(SI(Noms<>"";SI(NB.SI(I$1:I1;Noms)=0;LIGNE(INDIRECT("1:"&LIGNES(Noms)));LIGNES(Noms)))))
Données/Validation en B2:
=DECALER(Prenoms;EQUIV($A$2;Noms;0)-1;;NB.SI(Noms;$A$2))
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
Target.Offset(0, 1) = Empty
n = Application.CountIf([CP], Target)
Select Case n
Case 1
Target.Offset(0, 1) =
[CP].Find(Target, LookAt:=xlWhole).Offset(0, 1)
Case Is > 1
Target.Offset(0, 1).Select
SendKeys "%{down}"
End Select
End If
End Sub
Données/Validation comptabilité
Les comptes sont regroupés en fonction des 2 premiers caractères .
Noms de champ
Comptes =DECALER(Feuil1!$A$2;;;NBVAL(Feuil1!$A:$A))
Groupes =DECALER(Feuil1!$B$2;;;NB.SI(Feuil1!$B$2:$B$29;"><"&""))
Liste des groupes
En B2:=INDEX(GAUCHE(Comptes;2);MIN(SI(Comptes<>"";
SI(NB.SI(B$1:B1;GAUCHE(Comptes;2))=0;LIGNE(INDIRECT("1:"&LIGNES(Comptes)));LIGNES(Comptes)))))
Données/Validation pour le choix du compte
en G2
=DECALER(Comptes;EQUIV(E2&"*";Comptes;0)-1;0;NB.SI(Comptes;E2&"*"))
Si les comptes ne sont pas triés DvComptabilité2
Liste en cascade avec 3 colonnes affichées
Noms de champ à créer
Choix1 =Lista!$D$1:$IV$1
Choix2 =Lista!$D:$D
Liste1 =DECALER(Lista!$A$2;;;NB.SI(Lista!$A$2:$A$6;"<>0"))
-Créer le nom de champ Liste2:
=DECALER(Choix2;2;EQUIV(Devis!$A$6;Choix1;0)-1;NBVAL(DECALER(Choix2;;EQUIV(Devis!$A$6;Choix1;0)-1))-2;1)
-Créer le 2e menu avec =Liste2
-Modifier le nom de champ Liste2:
=DECALER(Choix2;2;EQUIV(Devis!$A$6;Choix1;0)-1;NBVAL(DECALER(Choix2;;EQUIV(Devis!$A$6;Choix1;0)-1))-2;4)
Pour autoriser seulement le choix du code dans la 2eme liste.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([A10:A20], Target) Is Nothing And Target.Count
= 1 Then
p = Application.Match(Target, Application.Index([Liste2],
, 1), 0)
If IsError(p) Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Else
Target.Offset(0, 1) =
Application.Index([Liste2], p, 2)
Target.Offset(0, 2) =
Application.Index([Liste2], p, 3)
End If
End If
End Sub
Pour récupérer le code et le libellé dans la même cellule
Décocher quand les Données invalides sont tapées
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([A10:A20], Target) Is Nothing And Target.Count
= 1 Then
p = Application.Match(Target, Application.Index([Liste2],
, 1), 0)
If IsError(p) Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Else
Application.EnableEvents = False
Target.Value = Target.Value
& " " & Application.Index([Liste2], p, 2)
Application.EnableEvents = True
End If
End If
End Sub
Variante avec la fonction Indirect()
Listes cascade avec grille
On ne fait apparaître que les noms pour la compétence choisie en A2.
En A10:
=SI(LIGNES($1:1)<=NB.SI(INDEX(cond;;EQUIV($A$2;competences;0));"x");
INDEX(noms;PETITE.VALEUR(SI(INDEX(cond;;EQUIV($A$2;competences;0))="x";LIGNE(noms));LIGNES($1:1))-LIGNE(noms)+1);"")
Valider avec maj+ctrl+entrée
Pour obtenir la liste des compétences pour un nom
=SI(LIGNES($1:1)<=NB.SI(INDEX(cond;EQUIV($A$2;noms;0););"x");
INDEX(competences;PETITE.VALEUR(SI(INDEX(cond;EQUIV($A$2;noms;0);)="x";COLONNE(competences));LIGNES($1:1))-
COLONNE(competences)+1);"")
Valider avec maj+ctrl+entrée
Suppression de vides
On affiche seulement les longueurs disponibles pour la hauteur choisie.
En B10:
=INDEX(longueur;PETITE.VALEUR(SI(DECALER(longueur;EQUIV($B$1;Hauteur;0);)<>"";COLONNE(DECALER(longueur;EQUIV($B$1;Hauteur;0);))-COLONNE($B$14)+1);COLONNES($A:A)))
Noms de champs
Hauteur =$B$15:$B$23
longueur =$C$14:$M$14
prix =$C$15:$M$23
Si on veut obtenir la liste sous forme d'une colonne:
=INDEX(longueur;PETITE.VALEUR(SI(DECALER(longueur;EQUIV($B$1;Hauteur;0);)<>"";COLONNE(DECALER(longueur;EQUIV($B$1;Hauteur;0);))-COLONNE($B$14)+1);LIGNES($1:1)))
Liste différence
On planifie des personnes pour différentes activités. Ne sont proposés dans les menus que les personnes non affectées.
DVDiff
DVDiffNum1_9
DVDiffForm
En E2:
=SI(LIGNES($1:1)<=NBVAL(Tous)-NBVAL(Choisis);
INDEX(Tous;PETITE.VALEUR(SI((NB.SI(Choisis;Tous)=0);LIGNE(INDIRECT("1:"&LIGNES(Tous))));LIGNES($1:1)));"")
Valider avec maj+ctrl+entrée
Choix facultatif
Une référence peut exister dans plusieurs rayons. Dans ce cas, l'opérateur choisit le rayon dans une seconde liste.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" And Target.Count = 1
Then
For i = 1 To Sheets("liste").Range("ref").Count
If Sheets("liste").Range("ref")(i)
= Target.Value Then
temp = temp &
Sheets("liste").Range("rayon")(i) & ","
End If
Next i
Target.Offset(, 1).Validation.Delete
Target.Offset(, 1).Validation.Add xlValidateList, Formula1:=Left(temp,
Len(temp) - 1)
a = Split(temp, ",")
Target.Offset(, 1) = a(0)
If UBound(a) > 1 Then
Target.Offset(, 1).Select
SendKeys "%{down}"
Else
Target.Offset(, 1).Validation.Delete
End If
End If
End Sub
Un article peut exister chez plusieurs fournisseurs
Private Sub UserForm_Initialize()
Set d = CreateObject("scripting.dictionary")
i = 0
For Each c In Application.Index([BD], , 1)
If Not d.exists(c.Value) Then
d(c.Value) = ""
Me.ComboBox1.AddItem c.Value
Me.ComboBox1.List(i, 1) = c.Offset(,
1)
i = i + 1
End If
d(c.Value) = c.Offset(, 1).Value
Next c
Me.ComboBox1.SetFocus
SendKeys "{F4}"
End Sub
Private Sub ComboBox1_Click()
Me.ComboBox2.Clear
i = 0
For Each c In Application.Index([BD], , 1)
If c.Value = Me.ComboBox1 Then
Me.ComboBox2.AddItem c.Offset(,
3)
Me.ComboBox2.List(i, 1) = c.Offset(,
4)
i = i + 1
End If
Next c
Me.ComboBox2.ListIndex = 0
Me.ComboBox2.BackColor = IIf(Me.ComboBox2.ListCount
> 1, vbRed, vbWhite)
End Sub
Private Sub CommandButton1_Click()
ActiveCell = Me.ComboBox1
ActiveCell.Offset(, 1) = Me.ComboBox2
Unload Me
End Sub
Liste en cascade VBA
On fait apparaître en colonne B les jours de la semaine choisie en A2.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$A$2" Then
For s = 1 To 53
temp = temp & s & ","
Next s
On Error Resume Next
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp,
Len(temp) - 1)
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
an = Year(Date)
d = 7 * [A2] + DateSerial(an, 1, 3) - Weekday(DateSerial(an,
1, 3)) - 5
temp = ""
For j = 0 To 6
temp = temp & Format(d + j, "ddd
dd mmm yy") & ","
Next j
[b2].Validation.Delete
[b2].Validation.Add xlValidateList, Formula1:=Left(temp,
Len(temp) - 1)
End If
End Sub
Grille de compétences
On veut la liste des noms pour une compétence.
Si la liste est < à 200 caractères ou Excel>2003:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([B2:B2], Target) Is Nothing And Target.Count
= 1 Then
p = Application.Match(Target.Offset(0, -1), [competences],
0)
For lig = 1 To [noms].Count
If Range("grille").Cells(lig,
p) = "x" Then temp = temp & Range("noms")(lig)
& ","
Next
On Error Resume Next
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp,
Len(temp) - 1)
End If
End Sub
Si la liste est > à 200 caractères (Excel >2007):
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([B2:B2], Target) Is Nothing And Target.Count
= 1 Then
p = Application.Match(Target.Offset(0, -1), [competences],
0)
ligneliste = 2
[K2:K1000].ClearContents
For lig = 1 To [noms].Count
If Range("grille").Cells(lig,
p) = "x" Then
Cells(ligneliste, "K")
= Range("noms")(lig)
ligneliste = ligneliste
+ 1
End If
Next
End If
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
Listes cascade avec classeur fermé (ADO)
Dim répertoire
Dim fichier
Private Sub UserForm_Initialize()
'Microsoft ActiveX Data Object 2.8 doit être
activé
Dim rs As ADODB.Recordset
Set cnn = New ADODB.Connection
répertoire = ThisWorkbook.Path & "\"
fichier = "continent.xls"
cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ="
& répertoire & fichier
Set rs = cnn.Execute("SELECT continent FROM BD WHERE
continent<>''Group By continent")
Me.ComboBox1.List = Application.Transpose(rs.GetRows)
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
SendKeys "{F4}"
End Sub
Private Sub ComboBox1_Change()
Dim rs As ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ="
& répertoire & fichier
Set rs = cnn.Execute("SELECT pays FROM BD WHERE continent='"
& Me.ComboBox1 & "'")
Me.ComboBox2.List = Application.Transpose(rs.GetRows)
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Me.ComboBox2.SetFocus
SendKeys "{F4}"
End Sub
Private Sub ComboBox2_Change()
ActiveCell = Me.ComboBox1
ActiveCell.Offset(, 1) = Me.ComboBox2
Unload Me
End Sub
Choix d'un produit et d'un fournisseur dans un fichier fermé(ADO)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([b7:b7], Target) Is Nothing And Target.Count
= 1 Then
UserForm1.Left = 100 + Target.Left
UserForm1.Top = 100 + Target.Top
UserForm1.Show
End If
End Sub
Dim répertoire
Dim fichier
Private Sub UserForm_Initialize()
'Microsoft ActiveX Data Object 2.8 doit être
activé
Dim rs As ADODB.Recordset
Set cnn = New ADODB.Connection
répertoire = ThisWorkbook.Path & "\"
fichier = "BDD MP.xls"
cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ="
& répertoire & fichier
Set rs = cnn.Execute("SELECT [Code Produit],[Désignation
MP] FROM BD WHERE [Code Produit]<>'' group BY [Code Produit],[Désignation
MP]")
Me.ComboBox1.List = Application.Transpose(rs.GetRows)
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
SendKeys "{F4}"
End Sub
Private Sub ComboBox1_Change()
Dim rs As ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ="
& répertoire & fichier
Set rs = cnn.Execute("SELECT [Désignation fournisseur]
FROM BD WHERE [Code Produit]='" & Me.ComboBox1 & "'")
Me.ComboBox2.List = Application.Transpose(rs.GetRows)
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Me.ComboBox2.SetFocus
End Sub
Private Sub ComboBox2_Change()
ActiveCell = Me.ComboBox1
ActiveCell.Offset(1) = Me.ComboBox2
ActiveCell.Offset(2) = Me.ComboBox1.Column(1)
Unload Me
End Sub
Planning avec double affectation(stage+salle)
Sur cet exemple, on affecte des stages et des salles. Une salle ne peut être affectée plusieurs fois à la même date.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As
Range, Cancel As Boolean)
UserForm1.Top = 110
UserForm1.Left = 150
UserForm1.Show
Cancel = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([planning], Target) Is Nothing Then
col1 = Target.Column
ligne1 = [planning].Row
Set mondico = CreateObject("Scripting.Dictionary")
On Error Resume Next
For Each c In Cells(ligne1, col1).Resize([planning].Rows.Count,
Target.Columns.Count).SpecialCells(xlCellTypeComments)
temp = Trim(c.Comment.Text)
mondico(temp) = temp
Next c
UserForm1.ComboBox2.Clear
For Each c In [ListeSalles]
If Not mondico.Exists(c.Value)
Then UserForm1.ComboBox2.AddItem c
Next c
sEnd If
End Sub
Private Sub B_ok_Click()
If Me.ComboBox1 = "" Then Exit Sub
For Each c In Selection
c.Value = Me.ComboBox1
c.Interior.ColorIndex = [listestages].Find(Me.ComboBox1).Interior.ColorIndex
c.Font.ColorIndex = [listestages].Find(Me.ComboBox1).Font.ColorIndex
If Me.ComboBox2 <> ""
Then
If Not c.Comment
Is Nothing Then c.Comment.Delete
c.AddComment
c.Comment.Text Text:=Me.ComboBox2.Value
c.Comment.Shape.TextFrame.AutoSize
= True
End If
Next
End Sub
Private Sub UserForm_Initialize()
Me.ComboBox1.List = [listestages].Value
Me.ComboBox2.List = [ListeSalles].Value
End Sub
Pour obtenir le planning des salles automatiquement:
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
[planSalles].ClearContents
[planSalles].ClearComments
[planSalles].Interior.ColorIndex = xlNone
For Each c In [planning]
If Not c.Comment Is Nothing Then
temp = Trim(c.Comment.Text)
Set result = [A6:A24].Find(what:=temp,
LookIn:=xlValues)
If Not result Is Nothing Then
Cells(result.Row, c.Column)
= c.Value
temp = Sheets("planning").Cells(c.Row,
1)
If temp <> ""
Then
Cells(result.Row,
c.Column).AddComment
Cells(result.Row,
c.Column).Comment.Text Text:=temp
Cells(result.Row,
c.Column).Comment.Shape.TextFrame.AutoSize = True
End If
Cells(result.Row, c.Column).Interior.ColorIndex
= [listeStages].Find(c.Value).Interior.ColorIndex
Cells(result.Row, c.Column).Font.ColorIndex
= [listeStages].Find(c.Value).Font.ColorIndex
End If
End If
Next
End Sub
Liste en cascade horizontale
Pour un client, on veut choisir un responsable parmi la liste des responsables du client.
Menus en cascade 3 niveaux tableaux
Liste en fonction du jour
En J2:
=SI(LIGNES($1:1)<=NBVAL(INDEX(Cond;;EQUIV($H$2;jours;0)));
INDEX(Noms;PETITE.VALEUR(SI((jours=$H$2)*(Cond="x");LIGNE(INDIRECT("1:"&LIGNES(Noms))));LIGNES($1:1)));"")
Valider avec Maj+ctrl+entrée
Divers
DV
Ajout Listes Multiples
DvCode
Disposition spéciale (3 niveaux)
Les niveaux 1 et 2 sont dans la même colonne. Les menus de niveau 1 sont espacés de 5 en 5.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set champ1 = Range("menu1")
Set champ2 = Range("menu2")
Set champ3 = Range("menu3")
If Not Intersect(champ1, Target) Is Nothing And Target.Count
= 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [choix1]: d1(c.Value) = "":
Next c
temp = Join(d1.keys, ",")
Target.Validation.Delete
If temp <> "" Then Target.Validation.Add
xlValidateList, Formula1:=temp
End If
'-- niveau 2
If Not Intersect(champ2, Target) Is Nothing And Target.Count
= 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
décal = ([menu1].Row + 1) Mod
5
ligne = Target.Row
y = (ligne + 1 - décal)
Mod 5 ' à adapter
For Each c In [choix2]
If c.Offset(, -1)
= Target.Offset(-y) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
temp = Join(d1.keys,
",")
Target.Validation.Delete
If temp <>
"" Then Target.Validation.Add xlValidateList, Formula1:=temp
End If
End If
'-- niveau 3
If Not Intersect(champ3, Target) Is Nothing And
Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
décal = ([menu1].Row
+ 1) Mod 5
ligne = Target.Row
y = (ligne + 1 - décal)
Mod 5 ' à adapter
For Each c In [choix3]
If c.Offset(0, -1)
= Target.Offset(0, -1) And _
c.Offset(0,
-2) = Target.Offset(-y, -1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
temp = Join(d1.keys,
",")
Target.Validation.Delete
If temp <>
"" Then Target.Validation.Add xlValidateList, Formula1:=temp
End If
End If
End Sub
ComboBox pour remplacer Données/Validation
Affiche un commentaire au survol des options du combobox.
ComboBox
Bulle
ComboBox
Bulle Cascade 3 niveaux
ComboBox Bulle
couleur
Private Sub ComboBox1_MouseMove(ByVal Button As Integer,
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Ligne = Int(Y / (ComboBox1.Font.Size * 1.22))
If Ligne < Me.ComboBox1.ListCount Then
On Error Resume Next
Me.TextBox1 = ComboBox1.List(Ligne + Me.ComboBox1.TopIndex,
1)
End If
End Sub
Affiche un commentaire dans la 2e colonne du combobox.
ComboBox 2 colonnes
ComboBox
2 colonnes Cascade