XL 2019 Filtre 3 critères minimum

phddesi

XLDnaute Junior
Bonjour
Pouvez-vous m’aider je souhaite un filtre avec 3 critères sur une colonne s’il vous plaît.
Merci d’avance
 
Dernière édition:

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
Un essai en PJ avec :
VB:
Sub Cherche()
    Range("A2:C" & Application.Max(2, [B65000].End(xlUp).Row)).ClearContents
    Application.ScreenUpdating = False
    Dim Tfiltre, BDD, Ligne%, i%, j%, k%
    Tfiltre = Range("G2:G" & [G65000].End(xlUp).Row)
    BDD = Sheets("Entrepot").Range("A2:C" & Sheets("Entrepot").[A65000].End(xlUp).Row)
    Ligne = 2
    For i = 1 To UBound(BDD)
        For j = 1 To UBound(Tfiltre)
            If BDD(i, 3) Like "*" & Tfiltre(j, 1) & "*" Then
                For k = 1 To 3
                    Cells(Ligne, k) = BDD(i, k)
                Next k
                Ligne = Ligne + 1
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub
 

Pièces jointes

  • Test 1.xlsm
    18.1 KB · Affichages: 4

sylvanu

XLDnaute Barbatruc
Supporter XLD
Vous ne pouvez pas avoir le beurre et l'argent du beurre. 😂
Soit les filtres sont dans le code et donc en "dur" et c'est immuable, soit les filtres sont programmables sur la feuille et vous pouvez tout avoir.
Ou vous créez un second bouton "Tout voir" pour remplir la fonction. Voir PJ.
A mon avis la première version est la plus "universelle", vous mettez les filtres que vous voulez, si vous voulez tout voir vous effacez les filtres.
 

Pièces jointes

  • Test 1 V3.xlsm
    19.1 KB · Affichages: 3

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonsoir Phddesi,
C'est plus clair maintenant.:)

Vous avez surement remarqué que dans les filtres, en VBA, on ne peut mettre que 2 critères.
Donc en PJ une tricherie :
On remplace les noms désiré par £Nom, on filtre sur 1 critère "£*" puis on supprime les £.
😂 Pas très orthodoxe mais efficace :
VB:
Sub Filtre_Hors_Samsung_BB()
    Ajout£
    Sheets("entrepot").Select
    Range("Base[#All]").Select
    ActiveSheet.ListObjects("Base").Range.AutoFilter Field:=3, _
    Criteria1:="<>*£*"
    Suppression£
    [A1].Select
End Sub
Sub Ajout£()
N = [Base].Rows.Count
For i = 1 To [Base].Rows.Count
    Tele = Left([Base[modele tele]].Item(i), 6)
    If Tele = "Samsun" Or Tele = "huawei" Or Tele = "BB" Then [Base[modele tele]].Item(i) = "£" & [Base[modele tele]].Item(i)
Next i
End Sub
Sub Suppression£()
N = [Base].Rows.Count
For i = 1 To [Base].Rows.Count
    If Left([Base[modele tele]].Item(i), 1) = "£" Then [Base[modele tele]].Item(i) = Mid([Base[modele tele]].Item(i), 2)
Next i
End Sub
 

Pièces jointes

  • Test (7).xlsm
    31.3 KB · Affichages: 8

phddesi

XLDnaute Junior
Bonsoir Phddesi,
C'est plus clair maintenant.:)

Vous avez surement remarqué que dans les filtres, en VBA, on ne peut mettre que 2 critères.
Donc en PJ une tricherie :
On remplace les noms désiré par £Nom, on filtre sur 1 critère "£*" puis on supprime les £.
😂 Pas très orthodoxe mais efficace :
VB:
Sub Filtre_Hors_Samsung_BB()
    Ajout£
    Sheets("entrepot").Select
    Range("Base[#All]").Select
    ActiveSheet.ListObjects("Base").Range.AutoFilter Field:=3, _
    Criteria1:="<>*£*"
    Suppression£
    [A1].Select
End Sub
Sub Ajout£()
N = [Base].Rows.Count
For i = 1 To [Base].Rows.Count
    Tele = Left([Base[modele tele]].Item(i), 6)
    If Tele = "Samsun" Or Tele = "huawei" Or Tele = "BB" Then [Base[modele tele]].Item(i) = "£" & [Base[modele tele]].Item(i)
Next i
End Sub
Sub Suppression£()
N = [Base].Rows.Count
For i = 1 To [Base].Rows.Count
    If Left([Base[modele tele]].Item(i), 1) = "£" Then [Base[modele tele]].Item(i) = Mid([Base[modele tele]].Item(i), 2)
Next i
End Sub
Merci pour votre retour j'essaie tout ça t je reviens vers vous
Mais cela semble déjà correct.
 

phddesi

XLDnaute Junior
Re,
Un essai en PJ avec :
VB:
Sub Cherche()
    Range("A2:C" & Application.Max(2, [B65000].End(xlUp).Row)).ClearContents
    Application.ScreenUpdating = False
    Dim Tfiltre, BDD, Ligne%, i%, j%, k%
    Tfiltre = Range("G2:G" & [G65000].End(xlUp).Row)
    BDD = Sheets("Entrepot").Range("A2:C" & Sheets("Entrepot").[A65000].End(xlUp).Row)
    Ligne = 2
    For i = 1 To UBound(BDD)
        For j = 1 To UBound(Tfiltre)
            If BDD(i, 3) Like "*" & Tfiltre(j, 1) & "*" Then
                For k = 1 To 3
                    Cells(Ligne, k) = BDD(i, k)
                Next k
                Ligne = Ligne + 1
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub
bonjour

je reviens vers vous est ce possible de masquer les lignes sans les supprimer.
bien cordialement
 

Discussions similaires

Réponses
6
Affichages
209