XL 2013 Filtre avec plusieurs mots clefs

siyaru

XLDnaute Nouveau
Bonjour,
J'ai une colonne avec des centaines de mots.
Je souhaite appliquer un filtre contenant une dizaine de mots clefs, si ma colonne contient un de ses mots clefs, il ne l'affiche pas.
En gros si contient le mot A ou contient le mot B ou contient le C etc alors il le supprimer de ma ligne.

Mais je cale :)

Merci à vous !
 

BOISGONTIER

XLDnaute Barbatruc
Bonjour,

VB:
Sub FiltreInverseListe()
  Set f = Sheets("feuil1")
  Set d = CreateObject("scripting.dictionary")     ' Liste à ne pas sélectionner
  d.CompareMode = vbTextCompare
  For Each c In f.Range("E2:E" & f.[E65000].End(xlUp).Row)
    d(c.Value) = ""
  Next c
  Set d2 = CreateObject("scripting.dictionary")    ' liste complémentaire
  d2.CompareMode = vbTextCompare
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
   If Not d.exists(c.Value) Then d2(c.Value) = ""
  Next c
  ActiveSheet.Range("$A$1:$A$10000").AutoFilter Field:=1, Criteria1:=d2.keys, Operator:=xlFilterValues
End Sub
Boisgontier
 

Fichiers joints

siyaru

XLDnaute Nouveau
Bonjour siyaru,

A tester dans le fichier joint:
Faire un appuis sur le bouton "Go"
Puis dans " l'InputBox entrer le mot à exclure " valider par "Ok"

Cordialement.
Bonjour,
Merci de votre retour.
Je viens de tester, cela fonctionne bien mais sur un seul mot, or j'aurais une vingtaine de mot à entrer, idéalement en une seule fois.
 

siyaru

XLDnaute Nouveau
Bonjour,

VB:
Sub FiltreInverseListe()
  Set f = Sheets("feuil1")
  Set d = CreateObject("scripting.dictionary")     ' Liste à ne pas sélectionner
  d.CompareMode = vbTextCompare
  For Each c In f.Range("E2:E" & f.[E65000].End(xlUp).Row)
    d(c.Value) = ""
  Next c
  Set d2 = CreateObject("scripting.dictionary")    ' liste complémentaire
  d2.CompareMode = vbTextCompare
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
   If Not d.exists(c.Value) Then d2(c.Value) = ""
  Next c
  ActiveSheet.Range("$A$1:$A$10000").AutoFilter Field:=1, Criteria1:=d2.keys, Operator:=xlFilterValues
End Sub
Boisgontier
Bonjour,
Merci de votre réponse.
Cela fonctionne partiellement, si ma liste brute ne contient qu'un seul mot cela fonctionne comme "lundi" mais si la cellule contient lundi je fais du foot, alors cela ne fonctionne pas :-(
 

siyaru

XLDnaute Nouveau
Bonjour,
Merci de votre réponse.
Je vous joints un exemple concret de mon fichier histoire d'y voir plus clair.
Cela évitera les erreurs de compréhension, j'ai du mal m'exprimer, mon fichier se présente sous cette forme ^^
 

Fichiers joints

BOISGONTIER

XLDnaute Barbatruc
Bonjour,

Avec le filtre élaboré

VB:
Sub FiltreInverseListe()
    Range("A1:A10000").AdvancedFilter Action:=xlFilterInPlace, _
       CriteriaRange:=Range("C1:C2"), Unique:=False
End Sub
Boisgontier
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Bonjour siyaru, mdo100, JB, le forum,

Voyez le fichier joint et cette macro qui utilise des tableaux VBA :
VB:
Sub lister()
Dim tablo, exclu, d As Object, i&, s, j%, n&
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
exclu = [D1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(exclu): d(exclu(i, 1)) = "": Next
For i = 2 To UBound(tablo)
    s = Split(tablo(i, 1))
    For j = 0 To UBound(s)
        If d.exists(s(j)) Then GoTo 1
    Next
    n = n + 1
    tablo(n, 1) = tablo(i, 1)
1 Next
With [F2] 'à adapter
    If n Then .Resize(n) = tablo
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
End Sub
La macro s'exécute chez moi en 23 millisecondes contre 53 millisecondes avec le filtre élaboré de JB.

Edit : testé avec le tableau recopié sur 117 000 lignes => ma macro 1,27 seconde, celle de JB 3,77 secondes.

Bonne journée.
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
On remarquera que ni ma macro précédente ni celle de JB n'excluent la ligne voiture b m w.

Pour y parvenir il faut supprimer les espaces dans la liste brute :
VB:
Option Compare Text 'la casse est ignorée

Sub lister()
Dim tablo, exclu, ub&, i&, x$, j&, n&
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
exclu = [D1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
ub = UBound(exclu)
For i = 2 To UBound(tablo)
    x = Replace(tablo(i, 1), " ", "") 'supprime les espaces
    For j = 2 To ub
        If InStr(x, exclu(j, 1)) Then GoTo 1
    Next
    n = n + 1
    tablo(n, 1) = tablo(i, 1)
1 Next
With [F2] 'à adapter
    If n Then .Resize(n) = tablo
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
End Sub
Fichier (2), sur 117 000 lignes c'est un peu plus long => 1,64 seconde.

A+
 

Fichiers joints

siyaru

XLDnaute Nouveau
Bonjour,
Je me permets de revenir vers vous car j'ai un bug.
J'ai ajouté une nouvelle liste a faire, j'ai modifié la macro comme voulue mais le trie ne se fait plus et je ne sais pas pourquoi :-(
Merci de votre aide !
 

Fichiers joints

BOISGONTIER

XLDnaute Barbatruc
Bonjour,

Dans le post #1, vous aviez mentionné une dizaine de mot-clefs. Ici, j'ai mis 100.
Vous pouvez aussi insérer des colonnes.

VB:
Sub FiltreInverseListe()
    Range("A1:A10000").AdvancedFilter Action:=xlFilterInPlace, _
       CriteriaRange:=Range("criteres"), Unique:=False
End Sub
Boisgontier
 

Fichiers joints

Dernière édition:

Discussions similaires


Haut Bas