Listes deroulantes en cascade avec plusieurs niveaux
Bonjour à tous,
J’ai un problème et j'ai besoin de votre aide, j’aimerai faire des listes deroulantes en cascade, j’ai beaucoup lu le site de jacques boisgontier mais je ne comprends pas vraiment ces exemples, j’ai un fichier avec 250000 lignes, donc avec la fonction indirect c’est assez laborieux, je vous met un exemple en pièce jointe, savez-vous comment faire ?
Merci,
Ambou
Bonjour,
sujet intéressant ... mais tu n'as pas 8 niveaux !
je vais regarder ce soir ... par VBA et dictionnary, je pense que c'est la seule méthode !
Bonjour Steelson,
Merci de ta reponse, je viens de changer le titre.
Ambou
Ah ben oui, il y en a bien 8 !!
Bonjour,
C'est aussi simple de filtrer chaque colonne les unes a la suite des autres !
et ça ne prend pas plus de temps de sélectionner un filtre (la liste est déjà faite) plutôt que de sélectionner la mème chose dans une liste !
A propos, il y a des doublons dans ton tableau.
Clique sur l'image
Crdlmt
VOICI
à tester ... j'espère que c'est bon !
[Bonsoir,
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([a2:f2], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [choix1]: d1(c.Value) = "": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")
End If
'-- niv 2
If Not Intersect([a3:f3], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [choix2]
If c.Offset(0, -1) = Target.Offset(-1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")
End If
End If
'---niv3
If Not Intersect([a4:f4], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [choix3]
If c.Offset(0, -2) = Target.Offset(-2) And _
c.Offset(0, -1) = Target.Offset(-1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")
End If
End If
'--- niv 4
If Not Intersect([a5:f5], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [choix4]
If c.Offset(0, -3) = Target.Offset(-3) And _
c.Offset(0, -2) = Target.Offset(-2) And _
c.Offset(0, -1) = Target.Offset(-1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")
End If
End If
'--- niv 5
If Not Intersect([a6:f6], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [choix5]
If c.Offset(0, -4) = Target.Offset(-4) And _
c.Offset(0, -3) = Target.Offset(-3) And _
c.Offset(0, -2) = Target.Offset(-2) And _
c.Offset(0, -1) = Target.Offset(-1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")
End If
End If
'--- niv 6
If Not Intersect([a7:f7], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [choix6]
If c.Offset(0, -5) = Target.Offset(-5) And _
c.Offset(0, -4) = Target.Offset(-4) And _
c.Offset(0, -3) = Target.Offset(-3) And _
c.Offset(0, -2) = Target.Offset(-2) And _
c.Offset(0, -1) = Target.Offset(-1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")
End If
End If
'--- niv 7
If Not Intersect([a8:f8], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [choix7]
If c.Offset(0, -6) = Target.Offset(-6) And _
c.Offset(0, -5) = Target.Offset(-5) And _
c.Offset(0, -4) = Target.Offset(-4) And _
c.Offset(0, -3) = Target.Offset(-3) And _
c.Offset(0, -2) = Target.Offset(-2) And _
c.Offset(0, -1) = Target.Offset(-1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")
End If
End If
End SubCeuzin
Très intéressant
J'ai eu un problème au lancement
ensuite les listes déroulantes s'appliquent sur la colonne a et non la colonne b
mais la réalisation est intéressante !
Je reviens sur la proposition de ceuzin que j'aime beaucoup.
Mais je pense qu'il y a matière à la retravailler, d'abord parce que je trouve qu'elle manque de réactivité, ensuite quand on change une valeur d'un niveau n il faudrait effacer les valeurs qui en dépendent de niveaux inférieur, et voir aussi si les propositions sont bien triées.
Bref un beau travail d'optimisation que je vais réaliser car c'est le genre de "gadget" utile.
Voici, sauf erreur de ma part
J'ai repris l'excellente proposition de ceuzin que je salue avec quelques aménagements :
On peut notamment mettre les zones où on veut sur la feuille (en les nommant zone1, zone2 etc.)
Le changement d'une valeur efface les dépendances
La macro est plus rapide car les données en tableau sont chargées
Pour l'adapter au nombre de zones, il suffit de changer la constante en début de macro
Const nbZones = 8
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim data() As Variant
Dim choix() As Variant
Dim dico As Object
Dim i&, iData&, iZone&
If Target.Count <> 1 Then Exit Sub
ReDim choix(1 To nbZones)
For i = 1 To nbZones
choix(i) = Range("zone" & i).Value
If Not Intersect(Range("zone" & i), Target) Is Nothing Then
data = [TabData].Value
Set dico = CreateObject("Scripting.Dictionary")
For iData = 1 To UBound(data)
flag = True
If i > 1 Then
For iZone = 1 To i - 1
If choix(iZone) <> CStr(data(iData, iZone)) Then flag = False
Next
End If
If flag Then dico(CStr(data(iData, i))) = ""
Next iData
If dico.Count > 0 Then
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Join(dico.keys, ",")
End If
Exit For
End If
Next i
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
For i = 1 To nbZones
If Not Intersect(Range("zone" & i), Target) Is Nothing Then
If i < nbZones Then
Application.EnableEvents = False
For iZone = i + 1 To nbZones
With Range("zone" & iZone)
.Value = ""
.Validation.Delete
End With
Next
Application.EnableEvents = True
End If
Exit For
End If
Next
End SubBonjour,
Version + rapide
http://boisgontierjacques.free.fr/fichiers/DonneesValidation/CascadeVBA6Niveaux.xls
http://boisgontierjacques.free.fr/fichiers/DonneesValidation/CascadeVBA6NiveauxVert.xls
X niveaux
http://boisgontierjacques.free.fr/fichiers/DonneesValidation/CascadeXNiveauxHoriz.xls
http://boisgontierjacques.free.fr/fichiers/DonneesValidation/CascadeXNiveauxVert.xls
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([a2:a20], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
TblBD = [Tableau1].Value
For i = 1 To UBound(TblBD): d1(TblBD(i, 1)) = "": Next i
temp = Join(d1.keys, ",")
Target.Validation.Delete
If temp <> "" Then Target.Validation.Add xlValidateList, Formula1:=temp
End If
'-- Niveau2
If Not Intersect([b2:b20], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
TblBD = [Tableau1].Value
tmp = Target.Offset(, -1)
For i = 1 To UBound(TblBD):
If TblBD(i, 1) = tmp Then d1(TblBD(i, 2)) = ""
Next i
If d1.Count > 0 Then
temp = Join(d1.keys, ",")
Target.Validation.Delete
If temp <> "" Then Target.Validation.Add xlValidateList, Formula1:=temp
End If
End If
'-- niveau 3
If Not Intersect([c2:c20], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
TblBD = [Tableau1].Value
tmp1 = Target.Offset(, -1)
tmp2 = Target.Offset(, -2)
For i = 1 To UBound(TblBD)
If TblBD(i, 1) = tmp2 _
And TblBD(i, 2) = tmp1 Then d1(TblBD(i, 3)) = ""
Next i
If d1.Count > 0 Then
temp = Join(d1.keys, ",")
Target.Validation.Delete
If temp <> "" Then Target.Validation.Add xlValidateList, Formula1:=temp
End If
End If
'-- niveau4
If Not Intersect([d2:d20], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
TblBD = [Tableau1].Value
tmp3 = Target.Offset(, -1)
tmp2 = Target.Offset(, -2)
tmp1 = Target.Offset(, -3)
For i = 1 To UBound(TblBD)
If TblBD(i, 1) = tmp1 _
And TblBD(i, 2) = tmp2 _
And TblBD(i, 3) = tmp3 Then d1(TblBD(i, 4)) = ""
Next i
If d1.Count > 0 Then
temp = Join(d1.keys, ",")
Target.Validation.Delete
If temp <> "" Then Target.Validation.Add xlValidateList, Formula1:=temp
End If
End If
'-- niveau 5
If Not Intersect([e2:e20], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
TblBD = [Tableau1].Value
tmp4 = Target.Offset(, -1)
tmp3 = Target.Offset(, -2)
tmp2 = Target.Offset(, -3)
tmp1 = Target.Offset(, -4)
For i = 1 To UBound(TblBD)
If TblBD(i, 1) = tmp1 _
And TblBD(i, 2) = tmp2 _
And TblBD(i, 3) = tmp3 _
And TblBD(i, 4) = tmp4 Then d1(TblBD(i, 5)) = ""
Next i
If d1.Count > 0 Then
temp = Join(d1.keys, ",")
Target.Validation.Delete
If temp <> "" Then Target.Validation.Add xlValidateList, Formula1:=temp
End If
End If
'-- niveau 6
If Not Intersect([F2:F20], Target) Is Nothing And Target.Count = 1 Then
Set d1 = CreateObject("Scripting.Dictionary")
TblBD = [Tableau1].Value
tmp5 = Target.Offset(, -1)
tmp4 = Target.Offset(, -2)
tmp3 = Target.Offset(, -3)
tmp2 = Target.Offset(, -4)
tmp1 = Target.Offset(, -5)
For i = 1 To UBound(TblBD)
If TblBD(i, 1) = tmp1 _
And TblBD(i, 2) = tmp2 _
And TblBD(i, 3) = tmp3 _
And TblBD(i, 4) = tmp4 _
And TblBD(i, 5) = tmp5 Then d1(TblBD(i, 6)) = ""
Next i
If d1.Count > 0 Then
temp = Join(d1.keys, ",")
Target.Validation.Delete
If temp <> "" Then Target.Validation.Add xlValidateList, Formula1:=temp
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([a2:a20], Target) Is Nothing And Target.Count = 1 Then
Target.Offset(, 1).Resize(, 5).Validation.Delete
Target.Offset(, 1).Resize(, 5) = ""
End If
'---
If Not Intersect([b2:b20], Target) Is Nothing And Target.Count = 1 Then
Target.Offset(, 1).Resize(, 4).Validation.Delete
Target.Offset(, 1).Resize(, 4) = ""
End If
'---
If Not Intersect([c2:c20], Target) Is Nothing And Target.Count = 1 Then
Target.Offset(, 1).Resize(, 3).Validation.Delete
Target.Offset(, 1).Resize(, 3) = ""
End If
'---
If Not Intersect([d2:d20], Target) Is Nothing And Target.Count = 1 Then
Target.Offset(, 1).Resize(, 2).Validation.Delete
Target.Offset(, 1).Resize(, 2) = ""
End If
If Not Intersect([e2:e20], Target) Is Nothing And Target.Count = 1 Then
Target.Offset(, 1).Resize(, 1).Validation.Delete
Target.Offset(, 1).Resize(, 1) = ""
End If
End SubCeuzin
Bonjour Steelson, ceuzin,
Merci beaucoup pour vos réponses, je ne m'attendais pas à ce que ce soit fait si rapidement et vu le nombres de lignes vous avez du y mettre beaucoup de temps (j'ai appris un peu le java en fac mais la ca va bien au-delà de ma compréhension).
Steelson : c'est parfait ce que tu as faire cependant j'obtiens quelques chose de bizarre lorsque je clic sur marque
ceuzin : est possible de ne pas afficher le cadre jaune mais juste de trier les titres comme ce qu'a fait Steelson car comme mentionner le fichier fait plus de 250000 lignes ?
Merci encore à vous deux.
Heu ... je ne comprends pas bien car chez moi c'est ok à partir du fichier que je viens de télécharger du site !!
Si quelqu'un a une réponse ...
Effectivement je viens de tester chez un ami sur son ordinateur ça marche !!
Merci énormément à vous deux vous venez de me faire gagner un temps fou !
Bon week-end
et nous (en tous cas moi), j'ai passé un super moment cérébral !
Sur un autre forum, jai fait un système à x niveaux.
Dim zSaisie, NbNiv
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set zSaisie = Range("B2:D4")
NbNiv = 3
If Not Intersect(zSaisie, Target) Is Nothing And Target.Count = 1 Then
TblBD = [Tableau1].Value
Set d1 = CreateObject("Scripting.Dictionary")
nivCourant = Target.Column - zSaisie.Column + 1
Dim Tmp(): ReDim Tmp(1 To nivCourant)
For k = 1 To nivCourant - 1
Tmp(k) = Target.Offset(, -(nivCourant - k))
Next k
For i = 1 To UBound(TblBD)
témoin = True
For k = 1 To nivCourant - 1
If TblBD(i, k) <> Tmp(k) Then témoin = False
Next k
If témoin Then d1(TblBD(i, nivCourant)) = ""
Next i
If d1.Count > 0 Then
temp = Join(d1.keys, ",")
Target.Validation.Delete
If temp <> "" Then Target.Validation.Add xlValidateList, Formula1:=temp
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(zSaisie, Target) Is Nothing And Target.Count = 1 Then
nivCourant = Target.Column - zSaisie.Column + 1
If nivCourant < NbNiv Then
Application.EnableEvents = False
Target.Offset(, 1).Resize(, NbNiv - nivCourant).Validation.Delete
Target.Offset(, 1).Resize(, NbNiv - nivCourant) = ""
Application.EnableEvents = True
End If
End If
End SubCeuzin