Recherche un peut particuliere

Le 03/09/2013 à 20:33

Bonsoir

J'ai un petit souci avec mon code.

Voilà j'ai fichier avec une feuille nommer "Choix" avec une liste de races de chien et leurs correspondances

ex; Chien de berger, chien d'aveugle ect... de la colonne "D : CZ".

J'ai un formulaire avec des optionboutton et 3 combobox alimenter: 1 Groupe, 1 Taille, 1 Pays d'origine;

J'aimerai faire une recherche en fonction des critères sélectionner.

ex: je coche chien de Compagnie, du groupe 9 par la combobox1, Angleterre parla combobox1 "Pays d'Origine" et petite taille par la combobox3.

Et j'aimerai que tous les chiens de compagnie du groupe 9 d'Angleterre et de petite taille se copie sur la feuille nommer "Résultat"

Je n'arrive pas a mettre mon fichiers trop gros 849kg je vous met mon code

Private Sub CommandButton1_Click()
Dim c As Object 'déclare la variable c (onglet Choix)
Dim r As Object 'déclare la variable r (onglet Résiltats)
Dim dl As Long 'déclare la variable dl (Dernière Ligne)
Dim pl As Range 'déclare la variable pl (PLAGE)
Dim pspl As Range 'déclare la variable pspl (Plage Sans Première Ligne)
Dim ctrl As Control 'déclare la variable ctrl (ConTRôLe)
Dim col As Byte 'déclare la variable col (COLonne)
Dim test As Boolean 'déclare la variable test

Set c = Sheets("Choix") 'définit l'onglet c
Set r = Sheets("Résultats") 'définit l'onglet r
r.Range("A6").CurrentRegion.Clear 'efface les éventuelles anciennes données de l'onglet r
r.Range("I1:I3").Clear
dl = c.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 1 (=A) de l'onglet c
Set pl = c.Range("A3:T" & dl) 'définit la plage pl
Set pspl = c.Range("A4:T" & dl) 'définit la plage pspl (Plage pl Sans la Première Ligne)
For Each ctrl In Me.Controls 'boucle sur tous les contrôles de l'UserForm
    If TypeOf ctrl Is msforms.OptionButton Then 'condition 1 : si le contrôle est un bouton d'option
        If ctrl = True Then 'condition 2 : si le bouton est coché
            col = CByte(ctrl.Tag) 'récupère la colonne dans la propriété "Tag" du contrôle
            test = True 'définit la variable test
            r.Range("I1") = ctrl.Caption 'place l'aptitude en I1 de l'onglet r
            Exit For 'sort de la boucle
        End If 'fin de la condition 2
    End If 'fin de la condition 1
Next ctrl 'prochain contrôle de la boucle
If c.FilterMode = True Then pl.AutoFilter 'si la plage pl est en mode filtre automatique, supprime le filtre automatique
If test = True Then pl.AutoFilter Field:=col, Criteria1:="X" 'filtre la plage par rapport au X dans la colonne col
If Me.ComboBox1.Value <> "" Then 'condition : si la ComboBox1 n'est pas vide
    pl.AutoFilter Field:=3, Criteria1:=Me.ComboBox1.Value 'filtre la plage pl par rapport au groupe
    r.Range("I2").Value = Me.ComboBox1.Value 'place le groupe en I2 de l'onglet r
End If 'fin de la condition
If Me.ComboBox2.Value <> "" Then 'condition si la ComboBox2 n'est pas vide
    Select Case Me.ComboBox2.Value 'agit en fonction de la valeur de la ComboBox2
        Case "Petite Taille" 'cas "Petite Taille"
            col = 18 'définit la colonne col
            r.Range("I3").Value = "Petite Taille" 'place la taille en I3 de l'onglet r
        Case "Moyenne Taille" 'cas "Moyenne Taille"
            col = 19 'définit la colonne col
            r.Range("I3").Value = "Moyenne Taille" 'place la taille en I3 de l'onglet r
        Case "GrandeTaille" 'cas "GrandeTaille" (il n'y a pas d'espace ?)
            col = 20 'définit la colonne col
            r.Range("I3").Value = "Grande Taille" 'place la taille en I3 de l'onglet r
    End Select 'fin de l'action en fonction de ...
    pl.AutoFilter Field:=col, Criteria1:="X" 'filtre par rapport au X dans la colonne col
End If 'fin de la condition
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante
'copie les coloones A à C de la plage pspl visible dans A6 de l'onglet r (génère une erreur si la plage pspl visible est vide)
Application.Intersect(pspl.SpecialCells(xlCellTypeVisible), c.Columns("A:C")).Copy r.Range("A6")
' If Err <> 0 Then MsgBox "Aucune chien trouvé avec ces critères" 'si une erreur a été générée, message
pl.AutoFilter 'supprime le filtre automatique
r.Select 'sélectionne l'onglet r
test = False 'initialise la variable test
End Sub

Private Sub UserForm_Initialize()
    Dim rg As Range

    'Groupe
    Set rg = Feuil3.Range("C2:C" & Feuil3.Range("C" & Rows.Count).End(xlUp).Row)
    Unique_Sorted_ComboList Me.ComboBox1, rg

    'Taille
    Set rg = Feuil3.Range("E2:E" & Feuil3.Range("E" & Rows.Count).End(xlUp).Row)
    Unique_Sorted_ComboList Me.ComboBox2, rg

    'Flag
    Set rg = Feuil3.Range("A2:A" & Feuil3.Range("A" & Rows.Count).End(xlUp).Row)
    Unique_Sorted_ComboList Me.ComboBox3, rg

End Sub

Je vous remercie de votre aide et vous souhaite une bonne soirée

Cordialement

Max

Le 03/09/2013 à 21:11

Bonjour Max

Sans le fichier, je crains que tu n'aies pas beaucoup de réponse.

Tu peux utiliser cjoint.com (gratuit et sans inscription) pour l'envoyer

Cordialement

Le 03/09/2013 à 21:27

Bonsoir Amadeus

Cela aurait était avec plaisir mais je ne sais pas comment joindre le fichier avec ci-joint.com si tu m'explique je l'envoie desuite

Max