XL 2010 Liste en cascade avec historique des éléments de la cellule

[idylh]

Bonjour,

J'ai créé une liste en cascade sur 3 niveaux à partir d'un exemple de boisgontier. J'ai rajouté la notion de sans doublon, MultiSelectExtended et modifié la séparation des données.
Par contre, quand je retourne sur ma cellule pour rajouter et/ou supprimer des éléments je suis obligée de tout remplir de nouveau.
Est-il possible de garder les infos déjà remplis sur les 3 niveaux lorsque je retourne sur ma cellule?
Merci pour votre aide.

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range(f.[A2], f.[A65000].End(xlUp)) 
  mondico(c.Value) = c.Value
  Next c
  Me.ListBox1.List = mondico.items
  Me.ListBox1.MultiSelect = fmMultiSelectExtended
End Sub

Private Sub ListBox1_Change() 
  Me.ListBox3.Clear
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range(f.[A2], f.[A65000].End(xlUp))
  For k = 0 To Me.ListBox1.ListCount - 1 
  If Me.ListBox1.Selected(k) = True Then
  If c = Me.ListBox1.List(k, 0) Then
  temp = c.Offset(, 1)
  mondico(temp) = temp
  End If
  End If
  Next k
  Next c
  Var = mondico.items
  Me.ListBox2.List = mondico.items
End Sub

Private Sub ListBox2_Change()

Dim mondico As Object
Set mondico = CreateObject("Scripting.Dictionary")
  Me.ListBox3.Clear
  For Each c In Range(f.[B2], f.[B65000].End(xlUp))
  For k = 0 To Me.ListBox2.ListCount - 1
  If Me.ListBox2.Selected(k) = True Then
  If c = Me.ListBox2.List(k, 0) Then
  
  If Not mondico.exists(c.Offset(, 1).Value) Then 
  mondico.Add c.Offset(, 1).Value, c.Offset(, 1).Value 
  Me.ListBox3.AddItem c.Offset(, 1)
  End If
  End If
  End If
  Next k
  Next c
End Sub

Private Sub b_ok_Click()
  temp = ""
  For k = 0 To Me.ListBox1.ListCount - 1
  If Me.ListBox1.Selected(k) = True Then temp = temp & Me.ListBox1.List(k, 0) & ","
  Next k
  If Len(temp) > 0 Then temp = Left(temp, Len(temp) - 1)
  ActiveCell = temp
  
  temp = ""
  For k = 0 To Me.ListBox2.ListCount - 1
  If Me.ListBox2.Selected(k) = True Then temp = temp & Me.ListBox2.List(k, 0) & ","
  Next k
  If Len(temp) > 0 Then temp = Left(temp, Len(temp) - 1)
  ActiveCell.Offset(, 1) = temp
  temp = ""
  For k = 0 To Me.ListBox3.ListCount - 1
  If Me.ListBox3.Selected(k) = True Then temp = temp & Me.ListBox3.List(k, 0) & ","
  Next k
  If Len(temp) > 0 Then temp = Left(temp, Len(temp) - 1)
  ActiveCell.Offset(, 2) = temp
  
  Unload Me
End Sub

 

[Bebere]

bonjour
idylh bienvenue
voilà un début pour garder les sélections
pour la suite il faudrait un fichier

Option Explicit
Public a1(), a2(), a(3)

Private Sub b_ok_Click()
    Dim i As Long, j As Long, nbSelect As Byte
    temp = ""
    For k = 0 To Me.ListBox1.ListCount - 1
        If Me.ListBox1.Selected(k) = True Then temp = temp & Me.ListBox1.List(k, 0) & ",": nbSelect = nbSelect + 1
    Next k
    If Len(temp) > 0 Then temp = Left(temp, Len(temp) - 1)
    ActiveCell = temp
    ReDim a1(nbSelect - 1): nbSelect = 0
    temp = ""
    For k = 0 To Me.ListBox2.ListCount - 1
        If Me.ListBox2.Selected(k) = True Then temp = temp & Me.ListBox2.List(k, 0) & ",": nbSelect = nbSelect + 1
    Next k
    If Len(temp) > 0 Then temp = Left(temp, Len(temp) - 1)
    ActiveCell.Offset(, 1) = temp
    ReDim a2(nbSelect - 1): nbSelect = 0
    temp = ""
    For k = 0 To Me.ListBox3.ListCount - 1
        If Me.ListBox3.Selected(k) = True Then temp = temp & Me.ListBox3.List(k, 0) & ",": nbSelect = nbSelect + 1
    Next k
    If Len(temp) > 0 Then temp = Left(temp, Len(temp) - 1)
    ActiveCell.Offset(, 2) = temp
        ReDim a3(nbSelect - 1)

    For i = 1 To 3
        j = 0
        For k = 0 To Me("ListBox" & i).ListCount - 1
            If Me("ListBox" & i).Selected(k) Then
                Select Case i
                Case 1
                    a1 (j): a1(j) = k: j = j + 1

                Case 2
                    a2 (j): a2(j) = k: j = j + 1

                Case 3
                    a2 (j): a2(j) = k: j = j + 1

                End Select
            End If
        Next i
        Unload Me
    End Sub

 

[idylh]

bonjour
idylh bienvenue
voilà un début pour garder les sélections
pour la suite il faudrait un fichier
End Sub[/code]

Bonjour,
Merci beaucoup, je désespérais d'avoir une réponse.
Ci-joint fichier test

 

[youky(BJ)]

Bonjour à tous,
Je pense répondre à la question.
Bruno

 

[idylh]

Je pense répondre à la question.

Bonjour,
Merci pour l'aide,
Ca marche seulement lorsque je choisis qu'un élément en niveau 1 et 2 et plusieurs en niveau 3.

 

[Bebere]

bonjour
idylh il me semble qu'avec une listbox qui reprend le tout
et faire la ou les sélections ce serait plus simple
autrement je pense qu' il faut ajouter des boutons pour valider

 

[BOISGONTIER]

Bonjour,

http://boisgontierjacques.free.fr/fichiers/Formulaire/ListBoxCascadeSelMultMemo2.xls

JB

 

[idylh]

bonjour
idylh il me semble qu'avec une listbox qui reprend le tout
et faire la ou les sélections ce serait plus simple
autrement je pense qu' il faut ajouter des boutons pour valider

Bonjour,
Merci, mais j'ai résolu mon problème grâce à Boisgontier

Bonjour,

http://boisgontierjacques.free.fr/fichiers/Formulaire/ListBoxCascadeSelMultMemo2.xls

JB

 

[Bebere]

au moins j'aurai appris quelque chose ,merçi