XL 2010 Tri Multi-Criteres par VBA suivant valeurs des cellules

LEIYAZ · 13 Décembre 2020

Bonjour,

J'ai un fichier de suivi de commandes sur lequel j'ai créer des cellules pour me permettre de trier par VBA la valeur de la cellule désignée.

Voici un exemple de code :

VB:

Sub trier_UG()

Sheets("BDD_Commandes_Devis").Unprotect Password:="0000"
Range("BD_Commandes[#Headers]").Select
Selection.AutoFilter
ActiveSheet.ListObjects("BD_Commandes").Range.AutoFilter Field:=10, _
Criteria1:=Range("d7").Value
ActiveWindow.SmallScroll Down:=-100
Range("d7").Select
Selection.ClearContents
Range("d7").Select
Sheets("BDD_Commandes_Devis").Protect Password:="0000", AllowSorting:=True, AllowFiltering:=True

End Sub

Le problème c'est que cela ne s'applique qu'a une seule colonne. J'aimerais pouvoir renseigner plusieurs critères dans plusieurs cellules et lancer une recherche VBA avec les lignes qui présentent les mêmes critères.

J'ai essayé de rentrer plusieurs critères :

VB:

Sub tri_MultiCriteres()

Sheets("BDD_Commandes_Devis").Unprotect Password:="0000"
Range("BD_Commandes[#Headers]").Select
Selection.AutoFilter


ActiveSheet.ListObjects("BD_Commandes").Range.AutoFilter Field:=5, _
Criteria1:=Range("d5").Value

ActiveSheet.ListObjects("BD_Commandes").Range.AutoFilter Field:=10, _
Criteria1:=Range("d7").Value


ActiveSheet.ListObjects("BD_Commandes").Range.AutoFilter Field:=2, _
Criteria1:=Range("d9").Value

ActiveSheet.ListObjects("BD_Commandes").Range.AutoFilter Field:=7, _
Criteria1:=Range("d11").Value


ActiveSheet.ListObjects("BD_Commandes").Range.AutoFilter Field:=14, _
Criteria1:=Range("d13").Value

ActiveSheet.ListObjects("BD_Commandes").Range.AutoFilter Field:=13, _
Criteria1:=Range("d15").Value



ActiveWindow.SmallScroll Down:=-100
Range("d15").Select
Selection.ClearContents
Range("d7").Select
Selection.ClearContents
Range("d5").Select
Sheets("BDD_Commandes_Devis").Protect Password:="0000", AllowSorting:=True, AllowFiltering:=True
End Sub

Mais cela crée des erreurs de résultats..

Pouvez vous m'aider ? Je vous mets en pièce jointe mon fichier.

Merci par avance

Phil69970 · 14 Décembre 2020

Bonjour LEIYAZ, le forum

1) Ce code remplace tous les autres codes des filtres.
2) Il filtre en fonction de la valeur remplie en D5, D7, D9, D11, D13 ou D15.
3) Il ne filtre QUE sur 1 seul critère, la 1ere valeur qu'il trouve de remplit (voir point 2)
4) A la fin de l'exécution du filtre tu as un retour avec un message sur les résultats qu'il a trouvé ou pas.
5) Je te laisse modifier les affectations du/des boutons pour les relier à cette procédure selon si tu veux garder 1 ou 6 boutons(c'est la même procédure qui marche pour tous les boutons, pas la peine de la copier 6 fois bien sur)

VB:

Sub Filtre()

Dim RechCritere  As Variant
Dim CelVal  As Range
Dim Fld As Integer
Dim Colonne As String...

Phil69970 · 14 Décembre 2020

Bonjour LEIYAZ, le forum

J'ai l'impression que tu confonds TRI et FILTRE.
Ton titre : Tri Multi-Criteres parle de tri
Et ton code fait des filtres.

Donc que veux tu faire ?

Ton code filtre fonctionne bien mais ne tri rien du tout.

J'ai un peu optimisé ton code qui FILTRE (le tien marche très bien).

VB:

[S]'Sub Tri_Multiple()[/S] 'Se n'est pas un TRI mais un FILTRE
Sub Filtre_Multiple()

Sheets("BDD_Commandes_Devis").Unprotect Password:="0000"
Range("BD_Commandes[#Headers]").AutoFilter

With ActiveSheet.ListObjects("BD_Commandes").Range
    .AutoFilter
    .AutoFilter Field:=5, Criteria1:=Range("D5").Value
    .AutoFilter Field:=10, Criteria1:=Range("D7").Value
    .AutoFilter Field:=2, Criteria1:=Range("D9").Value
    .AutoFilter Field:=7, Criteria1:=Range("D11").Value
    .AutoFilter Field:=14, Criteria1:=Range("D13").Value
    .AutoFilter Field:=13, Criteria1:=Range("D15").Value
End With

[D5].MergeArea.ClearContents
[D7].ClearContents
[D15].MergeArea.ClearContents

Sheets("BDD_Commandes_Devis").Protect Password:="0000", AllowSorting:=True, AllowFiltering:=True

End Sub

[S]'Sub trier_UG()[/S] 'Se n'est pas un TRI mais un FILTRE
Sub Filtre_UG()

Sheets("BDD_Commandes_Devis").Unprotect Password:="0000"
Range("BD_Commandes[#Headers]").AutoFilter

With ActiveSheet.ListObjects("BD_Commandes").Range
    .AutoFilter Field:=10, Criteria1:=Range("D7").Value
End With

[D7].ClearContents
Sheets("BDD_Commandes_Devis").Protect Password:="0000", AllowSorting:=True, AllowFiltering:=True
End Sub

@Phil69970

LEIYAZ · 14 Décembre 2020

Bonjour @Phil69970 , je vous remercie pour le code (je n'imaginais pas une réponse si tôt dans la journée ! ^^').

Je confond effectivement les tri et les filtres, je souhaite donc effectivement filtrer les données et non les trier.

Concernant le code, celui que vous m'avez donné fonctionne très bien, merci pour l'optimisation mais ce que je souhaites faire, c'est par exemple en activant cette macro rechercher une commande qui contient un ou plusieurs des critères de recherche spécifié dans les cellules concernées avec si possible une text box indiquant qu'aucun résultat n'a été trouvé.

Par exemple :

Or avec cette macro, il exécute la recherche de gauche a droite et si il ne trouve pas le résultat dans les premières colonnes, il ne trouve aucune correspondance sur les autres colonnes.

Merci de votre aide toujours précieuse

Phil69970 · 14 Décembre 2020

Bonjour LEIYAZ, le forum

1)Vu le nombre de critère de filtre important (ici tu en as 6) je pense que tu n'auras pratiquement jamais de résultat.

2)Pourquoi tu effaces seulement le résultat de 3 critères de filtres et pas des 3 autres ?

3)J'ai rajouté un message si la recherche ne trouve rien donc pratiquement tout le temps voir point 1

4)Pourquoi ne pas laisser seulement les filtres "individuels" et vouloir un multi filtre qui ne renverra presque jamais rien ?

VB:

Sub Filtre_Multiple()

Sheets("BDD_Commandes_Devis").Unprotect Password:="0000"
Range("BD_Commandes[#Headers]").AutoFilter

With ActiveSheet.ListObjects("BD_Commandes").Range
    .AutoFilter
    .AutoFilter Field:=5, Criteria1:=Range("D5").Value
    .AutoFilter Field:=10, Criteria1:=Range("D7").Value
    .AutoFilter Field:=2, Criteria1:=Range("D9").Value
    .AutoFilter Field:=7, Criteria1:=Range("D11").Value
    .AutoFilter Field:=14, Criteria1:=Range("D13").Value
    .AutoFilter Field:=13, Criteria1:=Range("D15").Value
End With

Dim VarFiltre As Integer
VarFiltre = Evaluate("SUBTOTAL(3,B21:B10000)")
If VarFiltre = 0 Then MsgBox "La recherche n'a pas aboutie, vous n'avez aucun résultat", vbCritical, "Résultat de la recherche"

[D5].MergeArea.ClearContents
[D7].ClearContents
[D15].MergeArea.ClearContents

Sheets("BDD_Commandes_Devis").Protect Password:="0000", AllowSorting:=True, AllowFiltering:=True

End Sub

@Phil69970

LEIYAZ · 14 Décembre 2020

Bonjour @Phil69970,

J'ai effectivement modifié mon code pour effacer les 3 autres critères de filtres.

Merci pour le MsgBox, je n'avais pas pensé a faire comme cela

Je vais laisser les filtres individuels, j'ai voulu essayer comme cela pour diminuer le nombre de résultats qui apparaissent.

Est-il possible de dire a excel en cliquant sur "rechercher" si il ne trouve pas de resultat sur la premiere colonne, de passer à la deuxieme etc jsuqu'a trouver le critère demandé ? Cela ne me laisserait qu'un seul bouton avec une macro unique au lieu de 6 boutons et 6 macros.

Par exemple j'ai pensé de dire à excel de ne trier que les cellules de critères remplies et de ne pas prendre en compte celles qui sont vides ?

Merci encore

Phil69970 · 14 Décembre 2020

Bonjour LEIYAZ, le forum

1) Ce code remplace tous les autres codes des filtres.
2) Il filtre en fonction de la valeur remplie en D5, D7, D9, D11, D13 ou D15.
3) Il ne filtre QUE sur 1 seul critère, la 1ere valeur qu'il trouve de remplit (voir point 2)
4) A la fin de l'exécution du filtre tu as un retour avec un message sur les résultats qu'il a trouvé ou pas.
5) Je te laisse modifier les affectations du/des boutons pour les relier à cette procédure selon si tu veux garder 1 ou 6 boutons(c'est la même procédure qui marche pour tous les boutons, pas la peine de la copier 6 fois bien sur)

VB:

Sub Filtre()

Dim RechCritere  As Variant
Dim CelVal  As Range
Dim Fld As Integer
Dim Colonne As String, Ligne As Long, Cel As String

With Sheets("BDD_Commandes_Devis")
    .Unprotect Password:="0000"
    Range("BD_Commandes[#Headers]").AutoFilter
    For Each CelVal In .Range("D5,D7,D9,D11,D13,D15")
        RechCritere = CelVal.Value
        If RechCritere > 0 Then
            Colonne = Left$(CelVal.Address(0, 0), (CelVal.Column < 27) + 2)
            Ligne = CelVal.Row
            Cel = Colonne & Ligne
            Range("BD_Commandes[#Headers]").AutoFilter
            With ActiveSheet.ListObjects("BD_Commandes").Range
                Select Case Cel
                Case "D5"
                    Fld = 5
                Case "D7"
                    Fld = 10
                Case "D9"
                    Fld = 2
                Case "D11"
                    Fld = 7
                Case "D13"
                    Fld = 3
                Case "D15"
                    Fld = 13
                End Select
                .AutoFilter Field:=Fld, Criteria1:=RechCritere
                Range(Cel).MergeArea.ClearContents
            End With
            'Exit Sub
        End If
    Next CelVal

    Dim VarFiltre As Integer
    Dim Derlig As Long
    Derlig = Worksheets("BDD_Commandes_Devis").Range("C" & Rows.Count).End(xlUp).Row - 20
    VarFiltre = Evaluate("SUBTOTAL(3,B21:B10000)")
    If VarFiltre = 0 Or VarFiltre = Derlig Then
        MsgBox "La recherche par filtre n'a pas aboutie, vous n'avez aucun résultat", vbCritical, "Résultat de la recherche"
        .Protect Password:="0000", AllowSorting:=True, AllowFiltering:=True
        Exit Sub
    End If
   
    .Protect Password:="0000", AllowSorting:=True, AllowFiltering:=True
   
    'Le message ci dessous peut etre supprimer si genant
    If VarFiltre = 1 Then
        MsgBox "Votre filtre a trouvé " & VarFiltre & " resultat", vbCritical, "Résultat de la recherche"
    Else
        MsgBox "Votre filtre a trouvé " & VarFiltre & " resultats", vbCritical, "Résultat de la recherche"
    End If
End With
End Sub

@Phil69970

LEIYAZ · 14 Décembre 2020

Bonjour,

Merci beaucoup @Phil69970 pour ces précieuses réponses, le code fonctionne parfaitement

Merci encore vous êtes les meilleurs

XL 2010 Tri Multi-Criteres par VBA suivant valeurs des cellules

LEIYAZ

XLDnaute Nouveau

Pièces jointes

Phil69970

Phil69970

XLDnaute Barbatruc

LEIYAZ

XLDnaute Nouveau

Phil69970

XLDnaute Barbatruc

LEIYAZ

XLDnaute Nouveau

Phil69970

XLDnaute Barbatruc

LEIYAZ

XLDnaute Nouveau

Discussions similaires