Accueil

Critère simple Critère ET Critère OU Statistiques Condition sur zone filtrée Extraction d'une liste sans doublons Doublons plusieurs colonnes Extraction entre 2 dates Extraction VBA Critère formule Filtre appatenance à une liste Lignes communes à 2 BD Extraction vers autre feuille Extraction vers autre classeur Suppression des lignes filtrées Valeur premier élément Positionnement premier élément Parcours des éléments visibles

-Extraction vers plusieurs onglets -1 ligne sur 4 -Extraction de la liste des doublons(1 critère) -Extraction de la liste des doublons(2 critères) -Liste sans doublons 2 critères plus récent -Suppression doublons 2 critères -Différence entre 2 listes (3 critères) -Extraction vers plusieurs onglets -Extraction automatique de noms sans doublons -Filtre gras -Filtre couleur -Extraction liste couleur -Filtre dynamique -Filtre OU -Filtre Ou Champs -Eléments communs à 2 listes -Lignes communes à 2 BD -Recherche Bibliothèque -Interrogation multiple -Filtre élaboré Listes -Intersection d'ensembles -Date au format jjmmaaaa -Filtre avec rubriques -Filtre élaboré cascade -Filtre élaboré majuscules/minuscules -Filtre sur une ou plusieurs régions -Recherche un mot dans une colonne de BD

De mise en œuvre plus complexe que le filtre Automatique, le filtre élaboré offre des
fonctionnalités supplémentaires:

• On peut choisir les champs récupérés et définir leur ordre
• Récupération des champs dans une autre feuille ou un autre classeur
• Critères de sélection + complexes

Critère simple

On veut obtenir la liste des personnes du service Compta

• Cliquer dans la base
• Données/Filtrer/Filtre élaboré
• Cocher Copier vers un autre emplacement
• Définir le critère (G1:G2)
• Définir la destination (G6:K6)

FiltreElaboré

Pour obtenir seulement Martin si plusieurs noms commencent par Martin

'=Martin
ou
="=Martin"

Critère ET

Les critères sont placés en ligne.
Les personnes du service compta ET dont le nom commence par D.

Critère OU

Les critères sont placés en colonne.

On veut la liste des ouvrages qui contiennent le mot basic OU fichier dans le titre

-Cliquer dans la base
-Données/Filtrer/Filtre élaboré
-Cocher Vers un autre emplacement

FiltreElabOU

Critère dynamique ET/OU de taille variable

Créer un nom de champ dynamique Critere avec Insertion/Nom/Définir

=DECALER(Feuil1!$E$1;;;MAX(SI($E$2:$F$8<>"";LIGNE($E$2:$F$8);0));2)

Statistiques

• Somme : =SOUS.TOTAL(9;C7:C34)
• Moyenne : =SOUS.TOTAL(1;C7:C34)
• Nombre : =SOUS.TOTAL(3;C7:C34)

FiltreElabStat

Condition sur une zone filtrée

Dans un filtre, on veut le nombre de réponses à OUI de la zone filtrée

=SOMMEPROD((SOUS.TOTAL(3;INDIRECT("D"&LIGNE(D2:D50)))*(D2:D50="OUI")))

Sans doublons

On veut récupérer la liste des services en G5

• Cliquer dans la base
• Données/Filtrer/Filtre élaboré
• Copier vers un autre emplacement
• Définir la destination (G1)
• Cocher Sans doublon

FiltreSD

En VBA:

Sub SansDoublons()
   [A1:D1000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[G1], Unique:=True
End Sub

Doublons sur plusieurs colonnes

• Cliquer dans la base
• Données/Filtrer/Filtre élaboré
• Cocher Vers un autre emplacement
• Cocher Extraction sans doublon
• Destination: G1:K1

Extraction entre 2 dates

ExtractionDates

Saisie des dates avec un formulaire

Pour Excel 2007, lorsque le filtre est activé par VBA, les dates des cellules du critère doivent être
sous la forme mm/jj/aaaa.
Ci dessous, pour 2007, nous inversons le jour et le mois.

FiltreElabDate

Private Sub CommandButton1_Click()
  If Val(Application.Version) >= 12 Then
    [G2] = ">=" & Format(TextBox1, "mm/dd/yyyy")
    [H2] = "<=" & Format(TextBox2, "mm/dd/yyyy")
  Else
    [G2] = ">=" & TextBox1
    [H2] = "<=" & TextBox2
  End If
  [A1:E1000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[G1:H2], CopyToRange:=[G6:K6]
End Sub

Autre solution compatible 2000-2007

Les dates sont saisies sous forme jj/mm/aa en G2 et H2. Le critère en J1:J2 est:

=ET(E2>=$G$2;E2<=$H$2)

ExtractionDates

Extraction VBA:

La syntaxe de l'extraction est la suivante:

Champ.AdvancedFilter Action:=xlFilterCopy/xlFilterInPlace, CriteriaRange:=champ,
  CopyToRange:=Champ, Unique:=True/False

[A1:B1000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[E1:E2], _
     CopyToRange:=[E5], Unique:=True

Autre exemple

On extrait les factures d'une personne de la feuille BD dans un autre onglet Extrait.

ExtraitBD
ExtraitBD2

Private Sub Worksheet_Change(ByVal Target As Range)
  Sheets("Factures").[A1:H1000].AdvancedFilter Action:=xlFilterCopy, _
     CriteriaRange:=[A1:A2], CopyToRange:=[A5:D5]
End Sub

Extraction dynamique

Extrait les personnes du service choisi en G3.
Dès qu'un nouveau service est saisi en colonne B, la liste en colonne L est mise à jour.

ExtractionDynamique
ExtractionDynamique2

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 2 And Target.Count = 1 Then
    Application.EnableEvents = False
    A1:D1000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[L1], Unique:=True
    [L2:L1000].Sort Key1:=[L2]
    Application.EnableEvents = True
  End If
  '--- extraction des personnes d'un service
  If Target.Address = "$G$2" Then
     [A1:D1000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[G2:G3], CopyToRange:=[G6:J6]
   End If
End Sub

Critère avec formule

Exemple1:On veut extraire les lignes pour lesquelles les années de naissance(colonne E) sont égales à l'année en K2

La première cellule du critère (G1) peut contenir n'importe quelle valeur SAUF un NOM de CHAMP.

• Cliquer dans la base
• Données/Filtrer/Filtre élaboré
• Copier vers un autre emplacement
• Définir le critère (G1:G2)
• Définir la destination (G6:K6)

FiltreAnnée

Exemple2: on veut la liste des vendeurs qui ont plus de 10 ventes

• Cliquer dans la base
• Données/Filtrer/Filtre élaboré
• Copier vers un autre emplacement
• Cocher sans doublon
• Définir le critère (I1:I2)
• Définir la destination (I5:J5)

Exemple3: On veut la liste des vendeurs qui ont total de ventes>500 000

• Cliquer dans la base
• Données/Filtrer/Filtre élaboré
• Copier vers un autre emplacement
• cocher Sans doublon
• Définir le critère (H1:H2)
• Définir la destination (H7:I7)

Exemple4: On veut la liste des ouvrages qui contiennent les mots basic et fichier dans le titre

• Cliquer dans la base
• Données/Filtrer/Filtre élaboré
• Cocher Vers un autre emplacement
• Critère :F1:F2
• Destination : F8:I8

FiltreElabET

Exemple 5 :On veut  extraire une liste de noms en doublons (nom)

En E2:=NB.SI($A$2:$A$1000;A2)>1 ou

=SOMMEPROD(($A$2:$A$100=A2)*1)>1

• Cliquer sur A1
• Données/Filtre/Filtre élaboré
• Cocher Copier vers un autre emplacement
• Critère: E1:E2
• Destination :E5
• Cocher sans doublons

En VBA:

Sub ExtraitDoublons1()
  [A1:B1000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[E1:E2], _
     CopyToRange:=[E5], Unique:=True
End Sub

Exemple 6 :On veut  extraire une liste des doublons (nom+prénom)

En E2:=SOMMEPROD(($A$2:$A$8=A2)*($B$2:$B$8=B2))>1

Extraction dans la feuille active

• Cliquer sur A1
• Données/Filtre/Filtre élaboré
• Copier vers un autre emplacement
• Critère: E1:E2
• Destination :E6:F6
• Cocher Sans doublons

Extraction dans la feuille résultat

• Se placer dans Resultat
• Cliquer sur A1
• Données/Filtre/Filtre élaboré
• Copier vers un autre emplacement
• Plage : sélectionner la Base (A1:B13)
• Critère: E1:E2
• Destination :A1
• Cocher Sans doublons

En VBA:

Sub ExtraitDoublons2()
  [A1:B1000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[E1:E2], _
     CopyToRange:=[E5:F5], Unique:=True
End Sub

Vers une autre feuille

Sub ExtraitDoublonsResultat2()
  [A1:B1000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[E1:E2], _
     CopyToRange:=Sheets("resultat2").[A1], Unique:=True
End Sub

Exemple 7 :On veut  filtrer les personnes pour une année de naissance

FiltreElabAn

Private Sub B_ok_Click()
  [g2].Formula = "=YEAR(E2)=" & Me.an
  Range("A1:E1000").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
     Range("g1:g2"), Unique:=False
End Sub

Private Sub b_tout_Click()
   On Error Resume Next
   ActiveSheet.ShowAllData
End Sub

Exemple 8: Appartenance à un ensemble

On veut extraire les lignes de la BD qui ont une ville appartenant à une liste en I2:I5

Le critère contient =NB.SI(liste;B2)>0

FiltreAppartenance

Pour obtenir les lignes qui n'appartiennent pas à la liste, le critère contient =NB.SI(liste;B2)=0

Exemple 9: Extraire la liste des doublons

En E2:=NB.SI(B:B;B2)>1

ListeDoublons

Sub FiltreDoublons()
  [A1].CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[E1:E2], CopyToRange:=[G1:I1], Unique:=False
  [G1].CurrentRegion.Sort Key1:=Range("I2"), Order1:=xlAscending, Header:=lGuess
End Sub

Exemple 10: Filtre lignes vides

On veut extraire les factures non réglées.
En F2: =EstVide(D2) ou =D2=""

FiltreElabVide

Valeur du premier élément

=INDEX(A2:A1000;EQUIV(1;(SOUS.TOTAL(3;INDIRECT("a"&LIGNE(A2:A1000))));0))

Positionnement du curseur sur le premier élément

Sub positionnePremier()
  If Range("A:A").SpecialCells(xlCellTypeVisible).Areas(1).Count > 1 Then
    [A2].Select
  Else
    Range("A:A").SpecialCells(xlCellTypeVisible).Areas(2).Item(1).Select
  End If
End Sub

Parcours des éléments visibles

Sub parcoursItemsVisibles()
For Each c In Range("A2", [A65000].End(xlUp)).SpecialCells(xlCellTypeVisible)
MsgBox c.Value & " " & c.Address
Next c
End Sub

Doublons entre 2 listes

On veut récupérer en J2 les doublons de Nom2/Nom1

-Cliquer sur C2
-Données/Filtre/Filtre élaboré
-Cocher Copier vers un autre emplacement
. Critère:E1:E2
. Destination: E4

Doublons2Listes

Non correspondance

On extrait en colonnes F:G les lignes pour lesquelles le couple code postal/ville n'existe pas dans le tableau I2:J7

=SOMMEPROD((CodePostal=A2)*(Ville=B2))=0

NonCorrespondance

MEFC
-Sélectionner A2:B9
-Format/Mise en Forme conditionnelle/Formule
=SOMMEPROD((CodePostal=$A2)*(Ville=$B2))=0

Filtre Majuscules

Filtre Majuscules

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

Sub Tout()
  On Error Resume Next
  ActiveSheet.ShowAllData
End Sub

Exemples divers

FiltreElaboréNbSi

Suppression des lignes filtrées

Supprime les lignes filtrées.

FiltreElabSup

Sub Filtre()
   Range("A7:B12").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
   Range("A1:A2"), Unique:=False
End Sub

Sub suppression()
  If MsgBox("Etes vous sûr?", vbYesNo) = vbYes Then
     Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase"). _
     Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
     ActiveSheet.ShowAllData
  Else
     MsgBox "Annulé"
  End If
End Sub

Sub affichetout()
   ActiveSheet.ShowAllData
End Sub

Autre exemple

On veut éliminer les doublons sur le No.

On veut garder le premier

FiltreElabPremier

Si le critère est =(A1<>A2), la première ligne de la BD n'est pas extraite.

On veut garder le dernier

FiltreElabDernier

On veut extraire une liste sans les doublons Nom+Prénom

On veut extraire une liste sans doublons Nom+prénom en prenant le plus récent.

FiltreListeSansDoublons

En G2, le programme crée le critère =ESTERR(OU(1/(A1=A2);1/(B1=B2)))

Sub ExtractionFiltre()
  [A1].Sort Key1:=[A2], Order1:=xlAscending, Key2:=[B2] _
     , Order2:=xlAscending, Key3:=[E2], Order3:=xlDescending, Header:=xlGuess
  [G:G].Insert Shift:=xlToRight
  [G2].Formula = "=ISERR(OR(1/(A1=A2),1/(B1=B2)))"
  Sheets("extraction").Cells.ClearContents
  [A1:E1000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[G1:G2], _
     CopyToRange:=Sheets("extraction").[A1]
  [G:G].Delete Shift:=xlToLeft
End Sub

Suppression de doublons 2 critères

On veut supprimer les doublons Nom+Prénom en gardant le premier.
On utilise le filtre élaboré.

Le programme crée un critère en G2: =ET(A1=A2;B1=B2) pour sélectionner les doublons.
Ensuite ces doublons sont supprimés.

FiltreSupDoublons

Sub sup_Doublons()
   [A1].Sort Key1:=[A2], Order1:=xlAscending, Key2:=[B2] _
     , Order2:=xlAscending, Key3:=[E2], Order3:=xlDescending, Header:=xlGuess

   [G:G].Insert Shift:=xlToRight
   [G2].Formula = "=AND(A1=A2,B1=B2)"
   [A1:E1000].AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=[G1:G2]
   If MsgBox("Etes vous sûr?", vbYesNo) = vbYes Then
       Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase"). _
       Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
   Else
      MsgBox "Annulé"
   End If
   ActiveSheet.ShowAllData
   [G:G].Delete Shift:=xlToLeft
End Sub

Extraction sans doublon:on veut garder le premier

Dans l'exemple, la BD est triée par An,format,vins,prix.
il y a deux fois la référence 2003 Armailhac 750Ml. On veut garder uniquement le premier fournisseur(le moins cher).

Le critère en G2:=ESTERR(OU(1/(A1=A2);1/(B1=B2);1/(C1=C2)))

FiltreElaboréGardePremier

Lignes communes à 2 BD sur nom+prénom avec filtre élaboré

Formule du critère:
=SOMMEPROD(('BD2'!A2='BD1'!A1:A2000)*('BD2'!B2='BD1'!B1:B2000))>0

Sub ExtraitCommuns()
  Sheets("BD2").[A1:G2000].AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=[k1:k2], CopyToRange:=[A1:G1]
End Sub

Extrait Communs 2 BD

Pour la différence BD2-BD1, le critère devient

=SOMMEPROD(('BD2'!A2='BD1'!A1:A2000)*('BD2'!B2='BD1'!B1:B2000))=0

Différence entre 2 fichiers 3 critères

On veut extraire la différence antre 2 BD:

-Données/Filtrer/FiltreElaboré
-Plage: A1:C100
-Critère:E1:E2
-Copier dans:K1:M1

Diff2BD

AgeBD1 =$C$2:$C$30
AgeBD2 =$I$2:$I$9
NomBd1 =$A$2:$A$30
NomBD2 =$G$2:$G$30
PrenomBD1 =$B$2:$B$30
PrenomBD2 =$H$2:$H$30

Extraction vers une autre feuille

Il faut se placer dans la feuille où on veut le résultat (onglet résultatExtract)

• 1- Cliquer sur A3
• 2 - Données/Filtrer/Filtre élaboré
• 3 - Cocher Copier vers un autre emplacement
• 4- Choisir la base (Onglet VersAutreFeuille)
• 5 -Définir le critère (G1:G2)
• 6 -Définir la destination (A1:E1 sur onglet RésultatExtract)

En VBA:

Sub ExtraitVersAutreFeuille()
    Sheets("VersAutreFeuille").Range("A1:E17").AdvancedFilter Action:= _
        xlFilterCopy, CriteriaRange:=Sheets("VersAutreFeuille").Range("G1:G2"), _
        CopyToRange:=Sheets("ResultatExtract").Range("A1:E1"), Unique:=False
    Columns("C:C").EntireColumn.AutoFit
End Sub

Extraction vers un autre classeur

Il faut se placer dans le classeur (FiltreCible.xls") où on veut le résultat.

(onglet Cible)

• Cliquer sur A3
• Données/Filtrer/Filtre élaboré
• Cocher Copier vers un autre emplacement
• Choisir la base (Dans le classeur où est la base)
• Définir le critère (G1:G2)
• Définir la destination (A1:E1 dans le classeur FiltreCible.xls)

Sub FiltreAutreClasseur()
  ' le classeur cible existe (FiltreCible.xls)
  ' le classeur cible contient les en-têtes de colonne à extraire en A1:E1
  nf = ActiveWorkbook.Name
  ChDir ActiveWorkbook.Path
  Application.DisplayAlerts = False
  Workbooks.Open ("filtrecible.xls")
  Windows(nf).Activate
  Range("A1:E1000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("F1:F2"), _
      CopyToRange:=Workbooks("FiltreCible.xls").Sheets("Cible").Range("A1:E1"), Unique:=False
End Sub

Sub FiltreNouveauClasseur()
  'le classeur cible n'existe pas
  nf = ActiveWorkbook.Name
  Workbooks.Add
  nfCible = ActiveWorkbook.Name
  Windows(nf).Activate
  Range("A1:E1000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("F1:F2"), _
      CopyToRange:=Workbooks(nfCible).Sheets(1).Range("A1"), Unique:=False
End Sub

Extraction de plusieurs onglets

On veut extraire les fiches 2003,2004,2005 (validées par x) dans des onglets différents.

Extraction

Sub ExtraitOngletsAn()
  supOnglets
  For an = 2003 To 2005
    Sheets("FiltreCréeOnglets").[I2] = an
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets("FiltreCréeOnglets").Range("A1:G10000").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("FiltreCréeOnglets").Range("I1:J2"), CopyToRange:=Range("A1")
    Cells.EntireColumn.AutoFit
    ActiveSheet.Name = "An_" & an
  Next an
End Sub

Sub supOnglets()
  Application.DisplayAlerts = False
  For Each s In ActiveWorkbook.Sheets
    If Left(s.Name, 3) = "An_" Then s.Delete
  Next s
End Sub

Extraction avec menus déroulants

FiltreElaboré

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address = "$A$4" Then
    Set f = Sheets("bd")
    f.[A1:D1000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=f.[F1], Unique:=True
    f.[F1:F100].Sort Key1:=f.[F2], Order1:=xlAscending, Header:=xlGuess
  End If
  If Target.Address = "$B$4" Then
    Set f = Sheets("bd")
    f.[A1:D1000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=f.[G1], Unique:=True
    f.[G1:G100].Sort Key1:=f.[G2], Order1:=xlAscending, Header:=xlGuess
  End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$4" Or Target.Address = "$B$4" Then
    Set f = Sheets("bd")
    f.[A1:D1000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[A3:B4], CopyToRange:=[A7:D7]
  End If
End Sub

Recherche d'un mot dans une colonne de BD

Recherche Mot ComboBox
Recherche Mot TextBox

Private Sub ComboBox1_Click()
  Set fRech = Sheets("recherche")
  Set fbd = Sheets("bd")
  fRech.[J2] = "*" & Me.ComboBox1 & "*"
  fbd.Range("A1:F10000").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=fRech.Range("J1:J2"), CopyToRange:=fRech.Range("A1:F1")
End Sub

Suppression si colonnes différentes

On supprime les lignes pour lesquelles Colb est différent de ColC

Sub sup_diffColBColC()
  [G:G].Insert Shift:=xlToRight
  [G2].Formula = "=B2<>C2"
  [A1:E1000].AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=[G1:G2]
  If MsgBox("Etes vous sûr?", vbYesNo) = vbYes Then
    Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase"). _
    Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
  Else
    MsgBox "Annulé"
  End If
   ActiveSheet.ShowAllData
  [G:G].Delete Shift:=xlToLeft
End Sub

Extraction 1 ligne sur 4

Le critère contient =(MOD(LIGNE(A2)-2;4))=0.

Extraction automatique de noms triée sans doublons

On veut extraire sur la feuille Result une liste triée sans doublons des noms de la feuille BD pour lesquels journee>0.
La macro est exécutée lorsque la feuille Result est activée.
FiltreElaboreExtractAuto

Private Sub Worksheet_Activate()
   Sheets("bd").[A1:B1000].AdvancedFilter Action:=xlFilterCopy, _
   CriteriaRange:=Sheets("result").[D1:D2], CopyToRange:=[A1], unique:=True
      [A1:A300].Sort Key1:=[A2], Order1:=xlAscending, Header:=xlGuess
End Sub

Filtre sur caractères gras

En D2:=EstGras(A2)

Function EstGras(c As Range)
     EstGras = c.Font.Bold
End Function

On veut extraire les lignes qui contiennent un code

Filtre sur couleur

On veut filtrer par rapport à une couleur choisie en D5

FiltreGrasCouleur

En D2: =couleurfond(B2)=couleurfond($D$5)

Function CouleurFond(c As Range)
  CouleurFond = c.Interior.ColorIndex
End Function

Filtre couleur2

On veut extraire les noms de la liste (colonne F) qui sont coloriés en jaune.

FiltreExtraitListeCouleur

-Créer une fonction personnalisée

Function couleurfondM(c)
  Dim temp
  ReDim temp(1 To c.Count)
  For i = 1 To c.Count
     temp(i) = c(i).Interior.ColorIndex
  Next i
  couleurfondM = Application.Transpose(temp)
End Function

-Créer un nom de champ ListeNoms: $F$2:$F$5
-Créer un critère en D2: =SOMMEPROD((ListeNoms=A2)*(couleurfondM(ListeNoms)=6))>0
-Cliquer dans la base
-Données/Filtre/Filtre élaboré
-Plage: A1:B100
-Zone de critère: D1:D2
-Copier dans: H1

Filtre élaboré dynamique

-Pour extraire la liste des personnes de Paris, l'opérateur clique sur une cellule contenant Paris. On obtient un onglet Paris avec la liste des personnes.
-Pour extraire la liste des personnes de Production, l'opérateur clique sur une cellule contenant Production.

FiltreElaboreDynamique3

Sub extrait()
   Application.DisplayAlerts = False
   If ActiveCell.Row > 1 And ActiveCell <> "" Then
      nomOnglet = CStr(ActiveCell)
      titreCritere = Cells(1, ActiveCell.Column)
      Critere = ActiveCell
      On Error Resume Next
      Sheets(nomOnglet).Delete
      On Error GoTo 0
      Sheets.Add after:=Sheets(Sheets.Count)
      ActiveSheet.Name = nomOnglet
      [K1] = titreCritere
      [K2] = Critere
      Sheets("bd").[A1:E1000].AdvancedFilter Action:=xlFilterCopy, _
      criteriarange:=[k1:k2], CopyToRange:=Sheets(nomOnglet).[A1]
    End If
End Sub

Choix de plusieurs villes dans un filtre du type OU

L'opérateur choisit plusieurs villes dans un menu Données/Validation/Liste. Un critère du type OU
permet d'obtenir l'ensemble des personnes des villes choisies

FiltreOU

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$F$2" And Target.Count = 1 Then
     Application.EnableEvents = False
     On Error Resume Next
     ActiveSheet.ShowAllData
     p = Application.Match(Target, [crit], 0)
     If IsError(p) Then
        [D65000].End(xlUp).Offset(1, 0) = Target
     Else
       Cells(p, 4).Resize(1, 1).Delete Shift:=xlUp
     End If
     Application.EnableEvents = True
     [A7].CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=[crit]
  End If
End Sub

Sub tout()
[D2:D20] = Empty
[F2] = Empty
On Error Resume Next
ActiveSheet.ShowAllData
End Sub

Filtre OU entre champs

On veut filtrer les lignes qui contiennent le mot en I2

Eléments communs à 2 listes

Créer un critère en E2:=NB.SI($C$2:$C$10001;A2)>0

-Données/Filtre/Filtre élaboré
-Plages:A1:A10000
-Zone de critères:E1:E2
-Copier dans: G1

Pour une méthode plus rapide cf Dictionnary

Lignes communes à 2 BD dans 2 classeurs BD1.XLS et BD2.XLS

On récupère le résultat dans un troisième classeur (BD3.XLS).

-Ecrire en G2 de BD1.XLS la formule=NB.SI([BD2.xls]Feuil1!$B$2:$B$1000;B2)>0
-Se positionner en BD3 dans une cellule vierge
-Données/Filtre/Filtre élaboré
-Spécifier la plage de BD1.XLS: A1:D1000
-Spécifier le critère: G1:G2
-Spécifier la destination en BD3: A1:D1

Liste sans doublons sur les noms de email

On veut la liste des noms des emails sans doublons.

=NB.SI(A2:A100;GAUCHE(A2;TROUVE("@";A2))&"*")=1

Recherche bibliothèque

Donne les titres contenant le mot cherché

En F2:=ESTNUM(CHERCHE($D$2;A2))

RechercheBibli
RechercheBibliET
RechercheBibliOU

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$D$2" Then
     [A1:B1000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[F1:F2], _
       CopyToRange:=[H1:I1], Unique:=False
End If
End Sub

Interrogation multiple

FiltreElaboreInterroMultiple

En A2:
=SOMMEPROD(--((ListeMC=BD!E2)+(ListeMC=BD!F2)+(ListeMC=BD!G2)+(ListeMC=BD!H2)))

Private Sub Worksheet_Change(ByVal Target As Range)
  For Each c In [ListeMC]
     If c = "" Then c.Value = "."
  Next
  If Not Intersect([ListeMC], Target) Is Nothing And Target.Count = 1 Then
     Sheets("BD").Range("A1:H10000").AdvancedFilter Action:=xlFilterCopy, _
     CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("A6:H6"), Unique:=False
   End If
End Sub

Extraction pour des listes de sigles ET CP des colonnes F et H

La formule du critère en G2 est
=SOMMEPROD(--(ListeSigle=A2))*SOMMEPROD(--(ListeCP=C2))

Sub Extrait()
  Sheets("BD").[A1:D10000].AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=Sheets("BD").[J1:J2], CopyToRange:=Sheets("resultat").[A1:D1]
End Sub

FiltreElaboréListe

Filtre la base pour un des mots clés de la liste en D2:D6 ET pour l'année en F2

En A2:=(SOMMEPROD(ESTNUM(CHERCHE(Liste;$C10))*(Liste<>""))>0)*(SI($F$2>0;B10=$F$2;VRAI))

FiltreElaboréListe2

Sub Filtre()
[A9:C1000].AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=[A1:A2]
End Sub

Sub Tout()
On Error Resume Next
ActiveSheet.ShowAllData
End Sub

Intersection d'ensembles

Donne l'intersection des ensembles Genre,Ville,Qualif,service
(Pas sous forme de ET/OU classique)

Formule du critère en F2:
=(SI(NBVAL(CritGenre)=0;VRAI;SOMMEPROD(--(CritGenre=B9))))*
(SI(NBVAL(critville)=0;VRAI;SOMMEPROD(--(critville=C9))))*
(SI(NBVAL(CritQualif)=0;VRAI;SOMMEPROD(--(CritQualif=E9))))*
(SI(NBVAL(CritService)=0;VRAI;SOMMEPROD(--(CritService=F9))))

FiltreEnsemble

Noms de champ
Critère =BD!$H$3:$N$6
CritGenre =BD!$H$3:$H$6
CritQualif =BD!$L$3:$L$6
CritService =BD!$N$3:$N$6
critville =BD!$J$3:$J$6

Extraction avec critère date

Les dates en colonne J sont au format jjmmaaaa

Pour extraire les dates < à la date en N2, écrire en L2 le critère:
=DATE(DROITE(J2;4);STXT(J2;3;2);GAUCHE(J2;2))<$N$2

Le code VBA est

Sub extrait()
  Sheets("Foglio1").[A1:J10000].AdvancedFilter Action:=xlFilterCopy, _
  CriteriaRange:=Sheets("Foglio1").[L1:L2], CopyToRange:=Sheets("Foglio2").[A1]
End Sub

FiltreDate

Filtre élaboré avec rubriques

Le critère est composé de 3 rubriques

-A l'intérieur de chaque rubrique les critères sont du type OU
-On effectue un ET entre les rubriques cochées

FiltreElaboreRubrique

Critère en C2
=ET(SI($A$7=VRAI;OU(BD!O3=$E$4;BD!P3=$F$4;BD!Q3=$G$4;BD!R3=$H$4;BD!S3=$I$4);VRAI);
SI($A$8=VRAI;OU(BD!T3=$J$4;BD!U3=$K$4;BD!V3=$L$4;BD!W3=$M$4;BD!X3=$N$4);VRAI);
SI($A$9=VRAI;OU(BD!Y3=$O$4;BD!Z3=$P$4;BD!AA3=$Q$4;BD!AB3=$R$4;BD!AC3=$S$4;
BD!AD3=$T$4;BD!AE3=$U$4;BD!AF3=$V$4);VRAI))

Sub extrait()
  Sheets("BD").Range("A2:AL1000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("C1:C2"), _
    CopyToRange:=Range("d13:u13"), Unique:=False
End Sub

Filtre élaboré en cascade

On veut 3 Listes déroulantes liées, dont les propositions changent en fonction des choix préalables avec
la possibilité de commencer par celle que l'on veut.

FiltreElaboreCascade
FiltreElaboreCascade2

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address = "$B$4" Then
     Application.EnableEvents = False
     temp = Target
     Target = Empty
     Set f = Sheets("Données")
     Set g = Sheets("critères")
     f.[A1:F2000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[B3:D4], _
        CopyToRange:=g.[B2], Unique:=True
     g.[B2:B100].Sort Key1:=g.[B3], Order1:=xlAscending, Header:=xlGuess
        Target = temp
     Application.EnableEvents = True
   End If
   If Target.Address = "$C$4" Then
      Application.EnableEvents = False
      temp = Target
      Target = Empty
      Set f = Sheets("Données")
      Set g = Sheets("critères")
      f.[A1:F2000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[B3:D4], _
         CopyToRange:=g.[C2], Unique:=True
      g.[C2:C100].Sort Key1:=g.[C3], Order1:=xlAscending, Header:=xlGuess
      Target = temp
      Application.EnableEvents = True
   End If
   If Target.Address = "$D$4" Then  
     Application.EnableEvents = False
     temp = Target
     Target = Empty
     Set f = Sheets("Données")
     Set g = Sheets("critères")
     f.[A1:F2000].AdvancedFilter Action:=xlFilterCopy, _
       CriteriaRange:=[B3:D4], CopyToRange:=g.[D2], Unique:=True
     Target = temp
     Application.EnableEvents = True
   End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$B$4" Or Target.Address = "$C$4" Or Target.Address = "$D$4" Then
     Set f = Sheets("Données")
     f.[A1:F100].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[B3:D4], CopyToRange:=Sheets("Resultats").[A1:F1]
  End If
End Sub

Filtre élaboré Majuscules/Minuscules

FiltreMajusculesMinuscules

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$G$2" Then
     Range("A2:C10000").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("E1:E2")
  End If
End Sub

Filtre régions

On filtre pour une ou plusieurs régions choisies dans un ListBox.

FiltreRégions
FiltreRégionsFiltreElaboré

Private Sub Filtrer_Click()
  Application.ScreenUpdating = False
  Set f = Sheets("national")
  f.[i2:I100].ClearContents
  For i = 0 To Me.ListBox1.ListCount - 1
     If Me.ListBox1.Selected(i) = True Then f.[I65000].End(xlUp).Offset(1, 0) = Me.ListBox1.List(i)
  Next i
  f.Range("a8:f" & f.[f65000].End(xlUp).Row).AdvancedFilter Action:=xlFilterInPlace,   CriteriaRange:=f.[I1].CurrentRegion
  Unload Me
End Sub

Private Sub UserForm_Initialize()
  On Error Resume Next
  Sheets("national").ShowAllData
  ListBox1.MultiSelect = fmMultiSelectMulti
  ListBox1.List = Sheets("Régions").Range("F2:F28").Value
End Sub

Menu déroulant avec les noms des 30 premières lignes de la BD

Filtre Elaboré 30Lignes