Discussion :

[gigeof]

Bonjour a tous,

J'essaye de créer un fichier à sélection multiple dans 3 listBox en cascade. L'idée étant que la première listbox vous permette de déterminer le continu de la seconde et le croisement de la premier et la seconde déterminent le contenu de la troisième. Un peu comme si on appliquait un filtre Excel en entonnoirs sur 3 colonnes.

J'avais trouve un fichier en ligne correspondant a mon besoin - voir en pièce jointe, mais la macro ne semble pas accumuler les choix de la listbox 1 et de la listbox 2 pour afficher le contenu de la listbox 3. Il me manque donc une étape et je n'arrive pas a mettre le doigt sur la correction a effe.

Plus précisément, actuellement, par exemple si je sélectionne Adele en listbox 1 et piano en listbox2, je devrais avoir FA1, FA2, QA2 qui s'affichent en listbox3. Mais pour l'instant j'ai 14 possibilités qui s'affichent en listbox3 ce qui n'est pas ce que je souhaite.

Auriez-vous une idée a ajouter au code svp? la partie du code s'y referant est la suivante je pense:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
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 = fmMultiSelectMulti
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
    Me.ListBox2.List = mondico.items
End Sub
 
Private Sub ListBox2_Change()
  Me.ListBox3.Clear
  Set mondico = CreateObject("Scripting.Dictionary")
  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
         temp = c.Offset(, 1)
         mondico(temp) = temp
      End If
      End If
     Next K
  Next c
    Me.ListBox3.List = mondico.items
End Sub

Merci par avance de votre aide. En espérant que quelqu'un saura m'éclairer.

Cordialement,
Geoffrey

[Thautheme]

Bonsoir Gifeof, bonsoir le forum,

Remplace ton code par celui-ci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
Private OB As Worksheet
Private OC As Worksheet
Private TV As Variant
 
Private Sub UserForm_Initialize()
Dim D As Object
Dim I As Integer
 
Set OB = Worksheets("BD")
Set OC = Worksheets("Choix")
TV = OB.Range("A1").CurrentRegion
Set D = CreateObject("Scripting.Dictionary")
For I = 2 To UBound(TV, 1)
  D(TV(I, 1)) = ""
Next I
Me.ListBox1.List = D.keys
End Sub
 
Private Sub ListBox1_Change()
Dim D As Object
Dim I As Integer
Dim K As Integer
 
Me.ListBox2.Clear
Me.ListBox3.Clear
Set D = CreateObject("Scripting.Dictionary")
For I = 2 To UBound(TV, 1)
    For K = 0 To Me.ListBox1.ListCount - 1
      If Me.ListBox1.Selected(K) = True Then
        If TV(I, 1) = Me.ListBox1.List(K, 0) Then D(TV(I, 2)) = ""
      End If
    Next K
Next I
Me.ListBox2.List = D.keys
End Sub
 
Private Sub ListBox2_Change()
Dim D As Object
Dim I As Integer
Dim K1 As Integer
Dim K2 As Integer
 
Me.ListBox3.Clear
Set D = CreateObject("Scripting.Dictionary")
For I = 2 To UBound(TV, 1)
    For K1 = 0 To Me.ListBox1.ListCount - 1
        If Me.ListBox1.Selected(K1) = True Then
            If TV(I, 1) = Me.ListBox1.List(K1, 0) Then
                For K2 = 0 To Me.ListBox2.ListCount - 1
                    If Me.ListBox2.Selected(K2) = True Then
                        If TV(I, 2) = Me.ListBox2.List(K2, 0) Then D(TV(I, 3)) = ""
                    End If
                Next K2
            End If
        End If
    Next K1
Next I
Me.ListBox3.List = D.keys
End Sub
 
Private Sub b_ok_Click()
OC.Range("R2:T20").ClearContents
For K = 0 To Me.ListBox3.ListCount - 1
    If Me.ListBox3.Selected(K) = True Then OC.Cells(Application.Rows.Count, "R").End(xlUp).Offset(1, 0).Value = Me.ListBox3.List(K, 0)
Next K
For K = 0 To Me.ListBox2.ListCount - 1
    If Me.ListBox2.Selected(K) = True Then OC.Cells(Application.Rows.Count, "S").End(xlUp).Offset(1, 0).Value = Me.ListBox2.List(K, 0)
Next K
For K = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(K) = True Then OC.Cells(Application.Rows.Count, "T").End(xlUp).Offset(1, 0).Value = Me.ListBox1.List(K, 0)
Next K
 
OB.Range("A1:K1000").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=OC.Range("O1:O2"), CopyToRange:=OC.Range("C2:L2"), unique:=False
'InsèreLigne
Unload Me
End Sub
 
Sub InsèreLigne()
  Application.DisplayAlerts = False
  For I = [C65000].End(xlUp).Row To 4 Step -1
   If Cells(I, 3) <> Cells(I - 1, 3) Then Cells(I, 1).EntireRow.Insert
  Next I
End Sub