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
Repose en paix
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
 

Pièces jointes

  • Copie de FiltreInverseListe.xlsm
    25.2 KB · Affichages: 13

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 ^^
 

Pièces jointes

  • test2.xlsx
    16.3 KB · Affichages: 7

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Bonjour,

Avec le filtre élaboré

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

Boisgontier
 

Pièces jointes

  • FiltreInverseListe.xlsm
    31.2 KB · Affichages: 10
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.
 

Pièces jointes

  • test2(1).xlsm
    31 KB · Affichages: 4
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+
 

Pièces jointes

  • test2(2).xlsm
    30.8 KB · Affichages: 7

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 !
 

Pièces jointes

  • FiltreInverseListe_good.xlsm
    37.3 KB · Affichages: 4

Discussions similaires

Réponses
16
Affichages
981

Statistiques des forums

Discussions
311 713
Messages
2 081 808
Membres
101 819
dernier inscrit
lukumubarth