Listes en cascade

Accueil


Liste en cascade avec noms de champ et Indirect()
Listes dynamiques et Indirect()
Listes encascade avec noms de champ et Si()
Liste cascade onglets
Liste en cascade sans nom de champ
Ajout dynamique d'items
Listes en cascade avec prix
Listes cascade une seule cellule
Cascade 2 niveaux avec plusieurs choix de niveau2
Cascade sans nom de champ 3 niveaux
Listes cascade BD formules 2 niveaux
Liste cascade BD formules 3 niveaux
Liste cascade BD onglets formules 3 niveaux
Liste Cascade BD 2 colonnes
Liste noms commençant par une lettre
Noms commençant par les premières lettres
Noms contenant des letrres
Saisie intuitive tableur avec comboBox(saisie semi-automatique)
Simulation de Données/Validation avec saisie intuitive caractère par caractère
Saisie intuitive formulaire (saisie semi-automatique)
AutoCompletion avec ComboBox
Listes cascade dans un formulaire
Code postal
Choix d'un prénom pour un nom
Liste avec filtre
Choix multiples
Liste cascade BD 2 niveaux VBA
Liste cascade BD 3-4-5-6 niveaux VBA
Liste en fonction du jour

Items dans une colonne et choix dans une cellule
Code postal (plusieurs villes)
Plusieurs prénoms pour un nom
Comptabilité
Liste avec 3 colonnes affichées
Listes en cascade avec grille de compétences
Suppression de vides
Liste différence
Choix facultatif
Liste cascade VBA
Listes cascade avec classeur fermé (ADO)
Listes cascades ADO
Cascade 3 niveaux multi-sélection
Planning avec double affectation Stage/Salle
Liste en cascade horizontale

Formulaires en cascade

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&"*"))

DVCascadePremièresLettres

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)

DVCascade Indirect Formule

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 .

DvCreeListeBD

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

DVCascadeOnglets2

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

RecupérationCommentaire

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

DvCascadeUneCellulePrix

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

ListeCascade1celVBA

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

DV2nivPlusieursChoix

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)

DVSansNomChamp3niveaux
DVSansNomChamp3niveaux2

Cette version permet d'avoir le même modèle dans plusieurs marques.

DVSansNomChamp3niveaux

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)

DV3NiveauxOnglets

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

DV3Niv

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.

DvBus
FormBus

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

DV2Niv
DV2Niv2

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

DVCascadeBD5

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

Liste Cascade 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&"*"))

DVCascadePremièresLettres

Autre exemple

L'opérateur frappe la première lettre du produit pour obtenir la liste des produits commençant par la lettre choisie.

DVCascadePremièresLettres

Pour des nombres, formatter la colonne en texte

DVPremiersChiffres

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

DVPlusieursMots

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

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_Change()
  If Me.ComboBox1 <> "" Then
    Set d1 = CreateObject("Scripting.Dictionary")
    tmp = UCase(Me.ComboBox1) & "*"
    For Each c In Sheets("bd").[liste]
      If UCase(c) Like tmp Then d1(c.Value) = ""
    Next c
    Me.ComboBox1.List = d1.keys
    Me.ComboBox1.DropDown
    [e2] = Me.ComboBox1
  End If
End Sub

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

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

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

Données/validation permet la saisie intuitive (semi-automatique) :
-En frappant les premières lettres et en cliquant sur la flèche, on obtient la liste des items commençant par les lettres frappées. Mais elle ne permet pas d'obtenir la liste des items au fur et à mesure de la frappe des caractères comme sur Google.

-Ci dessous, lors du clic dans une cellule, un combobox apparaît, permettant une saisie intuitive caractère par caractère comme sur Google. La liste des noms de pays commençant par les lettres frappées apparaît automatiquement au fur et à mesure de la frappe des caractères. 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 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

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 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 Début Mac
Liste Déroulante Intuitive Form Contenu
Liste Déroulante Intuitive Form Contenu Filter
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

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

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

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

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

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

DV Ville CP

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&"*"))

DV Code Postal

Choix par code ou par ville

DV Code Postal

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

Form Code Postal ville

Listes en cascade dans un formulaire

DvCascadeForm

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.

DVCascadeForm

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 Régions Form
DV Choix Multiples Form

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 niveaux avec VBA

Liste cascade 2niv VBA
Liste cascade 2niv VBA 2
Liste cascade Pays Produit

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é

CascadeBD2niveaux

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 3 niveaux avec VBA

Il n'est pas obligatoire que la base de données soit triée.

ListeCascadeBD3niveaux
ListeCascadeBD3niveauxb
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
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 (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 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 3niv Inf200
ListeCascade 3niv Inf200 Une Cellule
ListeCascade 3nivInf200 Choix Interchangeable
Liste Cascade 3niv Inf8000
Liste Cascade 3niv Inf8000_2
Liste Cascade 4niv Inf8000
Liste Cascade 4niv Devis Inf8000
Liste Cascade 7niv vertical Inf8000

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

DV CascadePanneaux

=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

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

DVCodePostal
DVCodePostal2

=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

DvNomPrenom
DvNomPrenom3

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&"*"))

DvComptabilité

Si les comptes ne sont pas triés DvComptabilité2

Liste en cascade avec 3 colonnes affichées

DVCascade3colonnes

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

DVCascade2colonnesInd

Listes cascade avec grille

On ne fait apparaître que les noms pour la compétence choisie en A2.

DVCascadeCompétences

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

DVCascadeCompétences2

=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

DVSupVides

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.

DVFacultatif
DVPlusieurs ref

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

DVCascadeOptionel

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.

DvCascadeVBA

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:

DvCascadeCompetVBA

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)

ListesCascadeADO

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)

ADOFourn

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.

PlanningStageSalles

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.

DvCascadeHorizontale

Menus en cascade 3 niveaux tableaux

DV3Niveaux

Liste en fonction du jour

DVJour

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

 

 

 

 

 

 



 

 

 

 

 

 

 

 

 

 

 

 

 

Exemples

DV Cascade indirect
DV Cascade Sans Noms
DV Liste Cascade BD
DV Cascade Synthèse
DV cascade indirect 3 nv
DV département
DV cascade prix simple
DV cascade prix qte
DV liste différence
DV devis bd 2niveaux
DV cascade sans noms2
DV cascade sans noms3
DVCodePostal
DVCodePostal2
DV recettes
DV ajout 3listes
DV cascade lettre noms
DV cascade date ex
DV Liste Avertissement
DV Image
DV Ajout Liste
DV Cascade Noms
DV CodesPostaux
DV Cascades 3 niv BD
DV Cascade Tph
DV Dynamique
DV Cascade Alphabet
DV Sans Doublons
DV Cascade Dynamique
DV Cascade 3 niv BD
DV Cascade Dates
DV CreationListe VBA
DV NomUserReseau
DV Récup Couleur
DV Positionne Premier
DV Choix Successifs
DV Synhèse VBA
DV Cascade Prix
DVCascadePremierFourn


 
 
 
 
 
 
 
 
 
 
 
 
DVChoixRégionsForm