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

idylh · 24 Janvier 2018

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.

Code:

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 · 26 Janvier 2018

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

Code:

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 · 26 Janvier 2018

Bebere à dit:
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) · 26 Janvier 2018

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

idylh · 29 Janvier 2018

youky(BJ) à dit:
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 · 29 Janvier 2018

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 · 29 Janvier 2018

Bonjour,

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

JB

idylh · 29 Janvier 2018

Bebere à dit:
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

BOISGONTIER à dit:
Bonjour,

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

JB

Bebere · 29 Janvier 2018

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

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

idylh

XLDnaute Nouveau

Bebere

XLDnaute Barbatruc

idylh

XLDnaute Nouveau

Pièces jointes

youky(BJ)

XLDnaute Barbatruc

Pièces jointes

idylh

XLDnaute Nouveau

Bebere

XLDnaute Barbatruc

BOISGONTIER

XLDnaute Barbatruc

idylh

XLDnaute Nouveau

Bebere

XLDnaute Barbatruc

Discussions similaires