Discussion :

[cmrugby]

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]

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]

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]

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]

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]

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