Listes en cascade EXCEL

**cmrugby** · 09/04/2014, 16h23

Bonjour à tous!!

Je cherche à construire des listes en cascade sous excel.
Si on regarde le fichier joint, si on choisit en niveau 1 "1", le niveau 2 ne doit proposer comme choix que "A" et "B" et ainsi de suite.
Avec comme contrainte de pouvoir ajouter ou supprimer des éléments dans chaque niveau.

merci d'avance pour votre aide
liste cascade.xlsx

**Daniel.C** · 09/04/2014, 17h22

Bonjour,

J'ai mis les listes déroulantes en A1, B1 et C1. Il suffit de changer leur adresse dans le code. Dans le module ThisWorkbook :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Private Sub Workbook_Open()
    Dim Tabl() As Integer, Ctr As Integer
    Ctr = -1
    With Sheets("Feuil1")
        ReDim Tabl(Application.Count([A:A]))
        For Each C In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
            If Not IsNumeric(Application.Match(C.Value, Tabl, 0)) Then
                Ctr = Ctr + 1
                Tabl(Ctr) = C.Value
                Txt = Txt & "," & C.Value
            End If
        Next C
        Txt = Right(Txt, Len(Txt) - 1)
        With .[A1].Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=Txt
        End With
    End With
End Sub

Dans le module de Feuil1 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Tabl() As String, Ctr As Integer, C As Range
    If Target.Address = "$A$1" Then
        Ctr = -1
        ReDim Tabl(Application.CountA([B:B]))
        For Each C In Range("B2", Cells(Rows.Count, 2).End(xlUp))
            If C.Offset(, -1) = [A1] Then
            If Not IsNumeric(Application.Match(C.Value, Tabl, 0)) Then
                Ctr = Ctr + 1
                Tabl(Ctr) = C.Value
                Txt = Txt & "," & C.Value
            End If
            End If
        Next C
        Txt = Right(Txt, Len(Txt) - 1)
        With [B1].Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=Txt
        End With
    ElseIf Target.Address = "$B$1" Then
        Ctr = -1
        Txt = ""
        ReDim Tabl(Application.CountA([B:B]))
        For Each C In Range("C2", Cells(Rows.Count, 3).End(xlUp))
            If C.Offset(, -1) = [B1] Then
            If Not IsNumeric(Application.Match(C.Value, Tabl, 0)) Then
                Ctr = Ctr + 1
                Tabl(Ctr) = C.Value
                Txt = Txt & "," & C.Value
            End If
            End If
        Next C
        Txt = Right(Txt, Len(Txt) - 1)
        With [C1].Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=Txt
        End With
    End If
End Sub

**cmrugby** · 09/04/2014, 17h41

Merci pour cette réponse

Mais si la colonne A ne comporte pas des chiffres mais des lettres, le code ne fonctionne plus...

**Daniel.C** · 09/04/2014, 17h53

Oui, mais dans ton exemple, ce sont des nombres. Remplace :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ReDim Tabl(Application.Count([A:A]))

par :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ReDim Tabl(Application.CountA([A:A]))

dans la macro Workbook_Open.

**cmrugby** · 09/04/2014, 18h07

Merci

et si je veux que les listes déroulantes soit en G1 H1 I1 je modifie où?

Le but étant de pouvoir utiliser à terme ces listes déroulantes n'importe où dans le fichier....

**Daniel.C** · 09/04/2014, 18h29

J'ai marqué les endroits où les adresses déroulantes sont mentionnées :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Private Sub Workbook_Open()
    Dim Tabl() As Integer, Ctr As Integer
    Ctr = -1
    With Sheets("Feuil1")
        ReDim Tabl(Application.Count([A:A]))
        For Each C In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
            If Not IsNumeric(Application.Match(C.Value, Tabl, 0)) Then
                Ctr = Ctr + 1
                Tabl(Ctr) = C.Value
                Txt = Txt & "," & C.Value
            End If
        Next C
        Txt = Right(Txt, Len(Txt) - 1)
        With .[G1].Validation    '*** adresse de l'adresse de niveau 1
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=Txt
        End With
    End With
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Tabl() As String, Ctr As Integer, C As Range
    If Target.Address = "$G$1" Then   '*** adresse de la liste de niveau 1
        Ctr = -1
        ReDim Tabl(Application.CountA([B:B]))
        For Each C In Range("B2", Cells(Rows.Count, 2).End(xlUp))
            If C.Offset(, -1) = [G1] Then   '*** adresse de la liste de niveau 1
            If Not IsNumeric(Application.Match(C.Value, Tabl, 0)) Then
                Ctr = Ctr + 1
                Tabl(Ctr) = C.Value
                Txt = Txt & "," & C.Value
            End If
            End If
        Next C
        Txt = Right(Txt, Len(Txt) - 1)
        With [H1].Validation   '*** adresse de la liste de niveau 2
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=Txt
        End With
    ElseIf Target.Address = "$H$1" Then   '*** adresse de la liste de niveau 2
        Ctr = -1
        Txt = ""
        ReDim Tabl(Application.CountA([B:B]))
        For Each C In Range("C2", Cells(Rows.Count, 3).End(xlUp))
            If C.Offset(, -1) = [H1] Then   '*** adresse de la liste de niveau 2
            If Not IsNumeric(Application.Match(C.Value, Tabl, 0)) Then
                Ctr = Ctr + 1
                Tabl(Ctr) = C.Value
                Txt = Txt & "," & C.Value
            End If
            End If
        Next C
        Txt = Right(Txt, Len(Txt) - 1)
        With [I1].Validation   '*** adresse de la liste de niveau 3
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=Txt
        End With
    End If
End Sub

**boisgontierjacques** · 09/04/2014, 19h35

Bonsoir,

Avec cette version, la longueur des listes de validation n'est pas limitée

Jacques Boisgontier

**cmrugby** · 10/04/2014, 10h56

Merci

mais si je veux utiliser ces listes déroulantes où je veux (tel un copie/colle) comment faire?

**Daniel.C** · 10/04/2014, 11h58

Utilise la solution de Jacques Boisgontier.

**cmrugby** · 10/04/2014, 12h06

je ne comprends pas trop la mise en oeuvre.
Sur l'onglet BD il faut que je renseigne tout?
Dans mon fichier actuel (qui fait en réalité 1000 lignes et 5 colonnes), je n'ai rempli que les colonnes A à E...

**Daniel.C** · 10/04/2014, 12h20

Visiblement, tu ne connais pas VBA; ton classeur contient des nombres qui sont en réalité du texte; ton exemple affiche 3 colonnes alors que tu en as en réalité 5... Tu n'as pas peur de faire perdre leur temps à ceux qui tentent de t'aider.
Poste un classeur qui soit le reflet exact du classeur réel (pas besoin de toutes les lignes). Et explique précisément ton besoin (combien de listes déroulantes, dur quelle feuille etc.)

**cmrugby** · 10/04/2014, 14h29

Je suis vraiment désolé Daniel... Ce n'est pas mon but de vous faire perdre du temps et je suis désolé de ne pas avoir été assez précis...
Effectivement je suis un peu novice en VBA...
J'ai refait un fichier qui ressemble beaucoup à mon fichier final (j'ai réduit la taille de la BD)
Dans l'onglet BD nous avons 5 niveaux avec une colonne de séparation entre chaque.
Le but étant de venir remplir un onglet "liste" (là aussi raccourci) avec les listes déroulantes.
J'aimerais aussi pouvoir utiliser ces 5 listes déroulantes dans d'autres fichiers comme si je les copiais/collais.

J'espère être cette fois assez précis et je m'excuse encore ...

Encore merci

Voici le classeur:
TEST LISTES CASCADES.xlsx

**Daniel.C** · 11/04/2014, 11h56

Le classeur joint est compressé.

**cmrugby** · 11/04/2014, 12h17

Merci Daniel
Sur la sheet "BD" la hiérarchie pyramidale colonne L à T a été refaite à la mano?

**Daniel.C** · 11/04/2014, 12h26

Non, elle est faite par la macro située dan le module de la feuille BD. Elle se déclenche quand tu ajoutes ou supprimes des données à ta BD :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Private Sub Worksheet_Change(ByVal Target As Range)
    With Sheets("BD").ListObjects("Tableau1")
        .Sort.SortFields.Clear
        .Sort.SortFields.Add _
            Key:=Range("Tableau1[NIVEAU 1]"), SortOn:=xlSortOnValues, Order:= _
            xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add _
            Key:=Range("Tableau1[NIVEAU 2]"), SortOn:=xlSortOnValues, Order:= _
            xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add _
            Key:=Range("Tableau1[NIVEAU 3]"), SortOn:=xlSortOnValues, Order:= _
            xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add _
            Key:=Range("Tableau1[NIVEAU 4]"), SortOn:=xlSortOnValues, Order:= _
            xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add _
            Key:=Range("Tableau1[NIVEAU 5]"), SortOn:=xlSortOnValues, Order:= _
            xlAscending, DataOption:=xlSortNormal
        With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Range("Tableau1[[#All],[NIVEAU 1]]").AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=Range("L1"), Unique:=True
        Range("Tableau1[[#All],[NIVEAU 1]:[NIVEAU 5]]").AdvancedFilter Action:= _
            xlFilterCopy, CopyToRange:=Range("M1:N1"), Unique:=True
        Range("Tableau1[[#All],[NIVEAU 1]:[NIVEAU 5]]").AdvancedFilter Action:= _
            xlFilterCopy, CopyToRange:=Range("O1:P1"), Unique:=True
        Range("Tableau1[[#All],[NIVEAU 1]:[NIVEAU 5]]").AdvancedFilter Action:= _
            xlFilterCopy, CopyToRange:=Range("Q1:R1"), Unique:=True
        Range("Tableau1[[#All],[NIVEAU 1]:[NIVEAU 5]]").AdvancedFilter Action:= _
            xlFilterCopy, CopyToRange:=Range("S1:T1"), Unique:=True
    End With
End Sub

**cmrugby** · 11/04/2014, 13h59

Je rencontre une difficulté.
En effet le "tableau1" est de taille fixe or il faudrait qu'il soit configuré pour prendre toute la taille du tableau (à l'ouverture et quand on ajoute/supprime des lignes)
Sinon il y a aussi des manip' excel à faire pour les listes déroulantes? (hors VBA)

merci :=)

**Daniel.C** · 11/04/2014, 14h15

Non, bien sûr, le tableau est dynamique. Si tu ajoutes des données, par exemple remplis la cellule B112, tu vas voir le tableau s'ajuster en ajoutant une ligne supplémentaire. Il s'agit d'un tableau créé à partir de la plage et en utilisant la commande Tableau de l'onglet Insertion.

**cmrugby** · 14/04/2014, 09h51

Effectivement!! vous êtes vraiment génial

Merci beaucoup.

tout fonctionne

merci encore!!

Listes en cascade EXCEL [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager