Microsoft 365 Liste déroulante en cascadz à X niveaux

Eric&

XLDnaute Nouveau
Bonjour à toutes et à tous;
Je rencontre des problèmes pour créer des listes déroulantes en cascade à X niveaux.
J'ai trouvé un lien qui m'intéresse mais n'arrive pas à adapter la macro. Je vous joins un fichier avec les informations.

Merci d'avance de prendre de votre temps

Lien de le discussion : https://www.excel-downloads.com/threads/liste-droulante-en-cascades-5-niveaux.180466/)
de david84 post n°20

Eric
 

Pièces jointes

  • ClasseurForum.xlsx
    13.9 KB · Affichages: 22
C

Compte Supprimé 979

Guest
Bonjour Eric,

Voici
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim mondico, c, temp, BD As Range
  ' Créer la Base de Données en fonction de sa taille
  With Sheets("BDD")
    Set BD = .[A2].Resize(.[A2].CurrentRegion.Rows.Count - 1, _
      .[A2].CurrentRegion.Columns.Count)
  End With
  ' Vérifier qu'on se trouve dans la zone souhaitée
  If Target.Column >= Columns("FJ").Column _
    And Target.Column <= Columns("J").Column _
    And Target.Count = 1 Then
    
    ' Créer une instance de dictionnaire
    Set mondico = CreateObject("Scripting.Dictionary")
    
    ' Selon la colonne sélectionnée
    Select Case Target.Column
      ' On crée la liste déroulante voulu
      Case Columns("F").Column
        Target.Offset(, 1) = "": Target.Offset(, 1).Validation.Delete
        Target.Offset(, 2) = "": Target.Offset(, 2).Validation.Delete
        Target.Offset(, 3) = "": Target.Offset(, 3).Validation.Delete
        Target.Offset(, 4) = "": Target.Offset(, 4).Validation.Delete
        For Each c In Application.Index(BD, , 1)
          If Not mondico.Exists(c.Value) Then mondico.Add c.Value, c.Value
        Next c
      
      Case Columns("G").Column
        Target.Offset(, 1) = "": Target.Offset(, 1).Validation.Delete
        Target.Offset(, 2) = "": Target.Offset(, 2).Validation.Delete
        Target.Offset(, 3) = "": Target.Offset(, 3).Validation.Delete
        For Each c In Application.Index(BD, , 2)
          If Not mondico.Exists(c.Value) And c.Offset(0, -1) = Target.Offset(0, -1) Then
            mondico.Add c.Value, c.Value
          End If
        Next c
    
      Case Columns("H").Column
        Target.Offset(, 1) = "": Target.Offset(, 1).Validation.Delete
        Target.Offset(, 2) = "": Target.Offset(, 2).Validation.Delete
        For Each c In Application.Index(BD, , 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
          End If
        Next c
      
      Case Columns("I").Column
        Target.Offset(, 1) = "": Target.Offset(, 1).Validation.Delete
        For Each c In Application.Index(BD, , 4)
          If Not mondico.Exists(c.Value) And c.Offset(0, -1) = Target.Offset(0, -1) And _
            c.Offset(0, -2) = Target.Offset(0, -2) And c.Offset(0, -3) = Target.Offset(0, -3) Then
            mondico.Add c.Value, c.Value
          End If
        Next c
      
      Case Columns("J").Column
        For Each c In Application.Index(BD, , 5)
          If Not mondico.Exists(c.Value) And _
            c.Offset(0, -1) = Target.Offset(0, -1) And _
            c.Offset(0, -2) = Target.Offset(0, -2) And c.Offset(0, -3) = Target.Offset(0, -3) And _
            c.Offset(0, -4) = Target.Offset(0, -4) Then
            mondico.Add c.Value, c.Value
          End If
        Next c
    End Select
    ' Si le dictionnaire n'est pas vide
    If mondico.Count > 0 Then
      ' On crée la validation de donnée
      Target.Validation.Delete
      If mondico.Count = 1 Then
        Target = mondico.keys
        If Target.Column < Columns("J").Column Then Target.Offset(0, 1).Select
      Else
        For Each c In mondico.items: temp = temp & c & ",": Next c
        Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
      End If
    End If
  End If
End Sub

A+
 

Eric&

XLDnaute Nouveau
Bonjour à vous,
Bruno45 : Merci encore une fois de prendre de ton temps afin de m'aider. Je regarde ça, essaie de l'adapter à mon fichier original et reviens vers toi.

Boisgontier : Merci d'avoir pris le temps de repondre. Je conserve le lien que tu m'as transmis. Entre nous, je consulte régulièrement ton site et j'y trouve des réponses. Merci !!!!

MERCI à vous deux et aux autres personnes du site qui prennent de leur temps pour faire progresser les autres.
Bravo à tous pour votre bel état d'esprit
 

Discussions similaires

Réponses
8
Affichages
405

Statistiques des forums

Discussions
312 047
Messages
2 084 863
Membres
102 688
dernier inscrit
Biquet78