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

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