Listes en cascade EXCEL

Version imprimable

09/04/2014, 16h23
cmrugby

1 pièce(s) jointe(s)

Listes en cascade EXCEL

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
Pièce jointe 142524

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:

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:

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

09/04/2014, 17h41
cmrugby

Merci pour cette réponse :)
Mais si la colonne A ne comporte pas des chiffres mais des lettres, le code ne fonctionne plus...
09/04/2014, 17h53
Daniel.C

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

Code:

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

par :

Code:

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

dans la macro Workbook_Open.
09/04/2014, 18h07
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....

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

Code:

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:

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

09/04/2014, 19h35
boisgontierjacques

1 pièce(s) jointe(s)

Bonsoir,

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

Jacques Boisgontier
10/04/2014, 10h56
cmrugby

Merci :)
mais si je veux utiliser ces listes déroulantes où je veux (tel un copie/colle) comment faire?
10/04/2014, 11h58
Daniel.C

Utilise la solution de Jacques Boisgontier.
10/04/2014, 12h06
cmrugby

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...
10/04/2014, 12h20
Daniel.C

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.)
10/04/2014, 14h29
cmrugby

1 pièce(s) jointe(s)

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:
Pièce jointe 142617
11/04/2014, 11h56
Daniel.C

1 pièce(s) jointe(s)

Le classeur joint est compressé.
11/04/2014, 12h17
cmrugby

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

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:

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

11/04/2014, 13h59
cmrugby

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 :=)
11/04/2014, 14h15
Daniel.C

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.
14/04/2014, 09h51
cmrugby

Effectivement!! vous êtes vraiment génial :)

Merci beaucoup.

tout fonctionne :) merci encore!!