Modifier ce code et passer de 2 à 3 combo

[J-c]

Bonjour à tous et à toutes

J'ai pris ce code sur le site de BJ.
Je voulais le modifier pour l'utiliser avec 3 combobox
Mais je n'y arrive pas, mes compétances limitées ne me le permettent pas.
Pouvez vous m'aider,je vous joint le code d'origine et le fichier avec mes modif.
Cordialement J-C et merci à BJ .

Private Sub UserForm_Initialize()
   Set f = Sheets("continent")
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In f.Range("A2", f.[A65000].End(xlUp))
     If Not mondico.Exists(c.Value) Then mondico.Add c.Value, c.Value
   Next c
   Me.ComboBox1.AddItem "*"
   For Each i In mondico.items
     Me.ComboBox1.AddItem i
   Next
   Me.ComboBox1.ListIndex = 0
End Sub 

Private Sub ComboBox1_Change()
   Set f = Sheets("continent")
   Me.ComboBox2.Clear
   For Each c In f.Range("A2", f.[A65000].End(xlUp))
     If c = Me.ComboBox1 Or Me.ComboBox1 = "*" Then
        Me.ComboBox2.AddItem c.Offset(0, 1) 
     End If
   Next c
   Me.ComboBox2.ListIndex = 0
End Sub

 

[CBernardT]

Re : Modifier ce code et passer de 2 à 3 combo

Bonsoir J-c et le forum,

Un exemple assez semblable.

 

[J-c]

Re : Modifier ce code et passer de 2 à 3 combo

Bonsoir
Merci pour cette réponse,mais cette exemple m'obligerais à refaire toute
ma base de donnée, il y a plus de 6000 données.
J'ais également testé d'autres codes mais j'obtiend des delais d'ouverture de
l'Userform du genre 2 minutes pour une base de 500 données.
j'ais fait quelques teste avec l'exemple que je joint, il semble que ce soit plus rapide,mais il faudrait que je vois sur 3 Combobox maintenant, et je ne m'en sort pas.
Cordialement J-C

 

[CBernardT]

Re : Modifier ce code et passer de 2 à 3 combo

Re,

Un essai avec ta base de données.

 

[J-c]

Re : Modifier ce code et passer de 2 à 3 combo

Re Bonsoir

J'ais fait un teste avec plus de 500 données dans la base, et l'ouverture de
l'Userform est instantané.
C'est donc nettement mieux .
Mais la liste des combobox 2 et 3 n'est pas conditionné en fonction de la valeur sélectionné dans la combo précédente (les listes complète des données s'affiche dans les combo 2 et 3 sans qu'aucun tris ne soit effectué).
Merci pour l'aide j'y regarde de plus près demain, il y a du progrès
Cordialement J-C

 

[Lii]

Re : Modifier ce code et passer de 2 à 3 combo

Bon soir,

une adaptation (entre autres).

 

[J-c]

Re : Modifier ce code et passer de 2 à 3 combo

Bonjour à tous

Merci pour votre aide.
J'ai fait un test avec les modif apporté par Lii .
Tout fonctionne bien jusqu'au moment ou l'on selectionne dans la combo 1 une donnée qui se trouve au dela de la ligne 303 (Pourquoi ?) à partir de cette
ligne la combo 3 n'est plus allimenté.
Je joint le début de ma base,avec un peu plus de 800 données.
Cordialement J-C

 

[J-c]

Re : Modifier ce code et passer de 2 à 3 combo

Bonsoir à tous

Après de nombreux teste avec différent code il apparait que certaine valeurs de la collone C s'affiche dans la combo 3 et d'autre non,sans qu'il n'y ai aucun rapport avec leur position dans la collone .
Savez vous d'ou pourrais provenir ce problème.
Je pense qu'il est lié à la base de donné mais je ne trouve pas le problème.
Pièce jointe dans le post précédent.
Cordialement J-C

 

[pierrejean]

Re : Modifier ce code et passer de 2 à 3 combo

bonsoir J-c

Vois si cela te convient

 

[J-c]

Re : Modifier ce code et passer de 2 à 3 combo

Bonsoir à tous

Merci PierreJean pour cette réponse.
Cela fonctionne, mais il y a un petit souci :
Si la valeur selectionnée dans la combo 2 est un chiffre, il n'y a aucune proposition pour la combo 3 (la cascade s'arrête)

Private Sub ComboBox1_Change()
tableau = Sheets("continent").Range("A2:C" & Sheets("continent").Range("A65536").End(xlUp).Row)
ComboBox2.Clear: ComboBox3.Clear
Set coll = New Collection
 For n = LBound(tableau, 1) To UBound(tableau, 1)
  If ComboBox1 = tableau(n, 1) Then
    On Error Resume Next
      coll.Add tableau(n, 2), CStr(tableau(n, 2))
      If Err.Number = 0 Then ComboBox2.AddItem tableau(n, 2)
    On Error GoTo 0
  End If
 Next n
End Sub

Private Sub ComboBox2_Change()
 tableau = Sheets("continent").Range("A2:C" & Sheets("continent").Range("A65536").End(xlUp).Row)
 ComboBox3.Clear
 Set coll = New Collection
 For n = LBound(tableau, 1) To UBound(tableau, 1)
  If ComboBox1 = tableau(n, 1) And ComboBox2 = tableau(n, 2) Then
    On Error Resume Next
      coll.Add tableau(n, 3), CStr(tableau(n, 3))
      If Err.Number = 0 Then ComboBox3.AddItem tableau(n, 3)
    On Error GoTo 0
  End If
 Next n
End Sub
Private Sub UserForm_Initialize()
tableau = Sheets("continent").Range("A2:C" & Sheets("continent").Range("A65536").End(xlUp).Row)
Set coll = New Collection
ComboBox1.AddItem "*"
For n = LBound(tableau, 1) To UBound(tableau, 1)
 On Error Resume Next
   coll.Add tableau(n, 1), CStr(tableau(n, 1))
   If Err.Number = 0 Then ComboBox1.AddItem tableau(n, 1)
 On Error GoTo 0
Next n
End Sub

 

[pierrejean]

Re : Modifier ce code et passer de 2 à 3 combo

Re

Effectivement Excel avait de la difficulté a comparer un texte et un nombre
Cette version devrait mieux fonctionner

 

[J-c]

Re : Modifier ce code et passer de 2 à 3 combo

Bonjour

Merci PierreJean
Je pense que cette foie ci c'est bon.
Si non, à voir, je crois que ce code a l'aire de marcher avec des nombres également.

Dim Ws As Worksheet
Dim NbLignes As Integer
 
 
Private Sub UserForm_Initialize()
Dim j As Long
Dim kol As New Collection
 
Set Ws = Worksheets("base")
NbLignes = Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row
For j = 2 To NbLignes
    On Error Resume Next
    kol.Add Ws.Range("A" & j).Value, CStr(Range("A" & j).Value)
Next j
 
For j = 1 To kol.Count
    Me.ComboBox1.AddItem kol(j)
Next j
 
End Sub
 
 
Private Sub ComboBox1_Change()
Dim j As Long
Dim kol As New Collection
 
For j = 2 To NbLignes
    On Error Resume Next
    If CStr(Ws.Range("A" & j).Value) = Me.ComboBox1.Value Then kol.Add Ws.Range("B" & j).Value, CStr(Range("B" & j).Value)
Next j
Me.ComboBox2.Clear
For j = 1 To kol.Count
    Me.ComboBox2.AddItem kol(j)
Next j
End Sub
 
 
Private Sub ComboBox2_Change()
Dim j As Long
Dim kol As New Collection
 
For j = 2 To NbLignes
    On Error Resume Next
    If CStr(Ws.Range("A" & j).Value) = Me.ComboBox1.Value And CStr(Ws.Range("B" & j).Value) = Me.ComboBox2.Value Then kol.Add Ws.Range("C" & j).Value, CStr(Range("C" & j).Value)
Next j
Me.ComboBox3.Clear
For j = 1 To kol.Count
    Me.ComboBox3.AddItem kol(j)
Next j
End Sub

Cordialement J-C