De mise en œuvre plus complexe que le filtre Automatique,
le filtre avancé (é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 avancé (élaboré)
- Cocher Copier vers un autre emplacement
- Définir le critère (G1:G2)
- Définir la destination (G6:K6)
Pour obtenir seulement Martin si plusieurs noms commencent par Martin
'=Martin
ou
="=Martin"
Respect de la casse
Pour extraire seulement les personnes du service COMPTA écrit en majuscules.
Filtre
Elaboré Exact
En G1:Formule
En G2:=EXACT(B2;$L$2)
En L2: COMPTA
Critère ET
Les critères sont placés en ligne.
Les personnes du service compta ET dont
le nom commence par D.
Champs de la BD incomplets
Lorsque des champs de la BD sont incomplets, la critère avec la méthode classique donne des résultats faux.
Critère I1:J2
Sub Extrait()
Sheets("BD").Range("A1:AM10000").AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("critères").Range("I1:J2"),
CopyToRange:=Range( _
"Résultats!Extract"),
Unique:=False
End Sub
Il faut un critère formule (en En D2):
=ET(SI($B$1="*";VRAI;BD!N2=$B$1);SI($B$2="*";VRAI;BD!P2=$B$2))
L'extraction se fait avec:
Sub Extrait()
Sheets("BD").Range("A1:AM10000").AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("critères").Range("D1:D2"),
CopyToRange:=Range( _
"Résultats!Extract"),
Unique:=False
End Sub
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
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)
Autre exemple
Statistiques
- Somme : =SOUS.TOTAL(9;C7:C34)
- Moyenne : =SOUS.TOTAL(1;C7:C34)
- Nombre : =SOUS.TOTAL(3;C7:C34)
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
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
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.
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
ExtractionDates2
Saisie entre 2 dates avec possibilité de ne saisir qu'une date
Sur cet exemple, on peut:
-Saisir les 2 dates (on obtient de la date de début à la
date de fin)
-ou pas de date (on obtient tout)
-ou La date de début (on obtient de la date de début à
la fin)
-ou La date de fin (on obtient du début à la date de fin)
=SI(ET($C$1<>"";$C$2<>"");ET(BD!K2>=$C$1;BD!K2<=$C$2);
SI(ET($C$1<>"";$C$2="");BD!K2>=$C$1;
SI(ET($C$1="";$C$2<>"");BD!K2<=$C$2;VRAI)))
Filtre élaboré
entre 2 dates
Filtre élaboré
formule date
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
ExtraitOptions
ExtraitOptions2
ExtraitOptions3
Extrait Options multiples
Filtre Target
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
[Tableau1[#all]].AdvancedFilter Action:=xlFilterCopy,
CriteriaRange:=[A1:A2], CopyToRange:=[A5:G5]
End If
End Sub
Private Sub Worksheet_selectionChange(ByVal Target As Range)
If Target.Address = "$A$2" Then
Set d = CreateObject("scripting.dictionary")
For Each c In [Tableau1[Bénéficiaire]]
d(c.Value) = ""
Next c
If d.Count > 0 Then
temp = Join(d.keys, ",")
Target.Validation.Delete
Target.Validation.Add xlValidateList,
Formula1:=temp
End If
End If
End Sub
Filtre avec menus déroulants dans le critère
Filtre avec menus déroulants critère
Comparaison extraction BD avec Array
Le filtre avancé nécessite la présence
de titres dans la BD et une zone critère.
L'extraction avec le filtre avancé est plus rapide que l'utilisation
d'array().
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.
Extraction
Dynamique
Extraction Dynamique 2
Extraction Dynamique
3
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)
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
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 6Bis :On veut extraire une liste des doublons entre 2 listes (nom+prénom)
En K2: =SOMMEPROD(($E$2:$E$6=A2)*($F$2:$F$6=B2))>=1
Exemple 7 :On veut filtrer les personnes pour une année de naissance
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()
If ActiveSheet.FilterMode then 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
Filtre Appartenance contenu
Filtre Appartenance
Lettre
Filtre Appartenance motcléTitre
ET editeur
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
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=""
OU Exclusif
On veut les codes articles qui apparaissent en mai OU en octobre mais pas les deux
Code Article Stock date
1AA12202 4 mai
1AA12212 1 mai
1AA15263 4 octobre
1AA15263 4 mai
1AA15264 4 octobre
1AA15264 4 mai
1AA15265 20 octobre
1AA15265 28 mai
1AA15266 20 octobre
1AA15266 28 mai
1AA16201 5 octobre
=OU(($C2=$H$2)*(SOMMEPROD((codes=$A2)*(dates=$I$2))=0);($C2=$I$2)*(SOMMEPROD((codes=$A2)*(dates=$H$2))=0))
Sub extrait()
Sheets("base").Range("A1:C10000").AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("base").[F1:F2],
CopyToRange:=Sheets("result").[A1:C1]
End Sub
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
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
MEFC
-Sélectionner A2:B9
-Format/Mise en Forme conditionnelle/Formule
=SOMMEPROD((CodePostal=$A2)*(Ville=$B2))=0
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
Suppression des lignes filtrées
Supprime les lignes filtrées.
FiltreElabSup
FiltreElabSup2
FiltreElabSup3
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()
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
End Sub
Autre exemple
On veut éliminer les doublons sur le No.
On veut garder le premier
Si le critère est =(A1<>A2), la première ligne de la BD n'est pas extraite.
On veut garder le dernier
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.
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.
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)))
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
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
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
Autres exemples
Extrait vers
autre feuille
Filtre noms
Filtre avancé avec ComboBox intuitif
La liste du combobox se réduit au fur et à mesure de la frappe des caractères.
Option Compare Text
Dim choix()
Private Sub ComboBox1_GotFocus()
Set f = Sheets("bd")
a = f.Range("A2:A" & f.[A65000].End(xlUp).Row)
Set d = CreateObject("scripting.dictionary")
For Each c In a: d(c) = "": Next c
choix = d.keys
Me.ComboBox1.List = choix
End Sub
Private Sub ComboBox1_Change()
[G2] = Me.ComboBox1
If [G2] = "" Then [G2] = " "
Set d = CreateObject("Scripting.Dictionary")
tmp = Me.ComboBox1 & "*"
For Each c In choix
If c Like tmp Then d(c) = ""
Next c
Me.ComboBox1.List = d.keys
Me.ComboBox1.DropDown
Sheets("BD").Range("A1:J10000").AdvancedFilter
Action:= _
xlFilterCopy, CriteriaRange:=[G1:G2], CopyToRange:=[A5:J5]
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.
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
Filtre
avancé
Filtre avancé dynamique
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
Filtrage d'une fiche avec menu déroulant
Recherche d'un mot dans une colonne de BD
Recherche
Mot ComboBox
Recherche Mot Lien
Hyper
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
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.
-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.
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
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
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
End Sub
Filtre d'une liste (ensemble)
Filtre un ensemble de villes
Sub FiltreVilles()
Range("A1:B10000").AdvancedFilter Action:=xlFilterInPlace,
CriteriaRange:=[E1].CurrentRegion
End Sub
Sur cette version, la liste des villes est définie en VBA
Sub Filtre()
Tbl = Array("Paris", "Bordeaux", "Versailles")
[I1] = [B1]
[I2].Resize(UBound(Tbl) + 1) = Application.Transpose(Tbl)
Range("A1:B10000").AdvancedFilter Action:=xlFilterInPlace,
CriteriaRange:=[I1].Resize(UBound(Tbl) + 2)
[I1].Resize(UBound(Tbl) + 3).ClearContents
End Sub
Sub Filtre2()
Range("I2").Formula = "=SUMPRODUCT(--(({""Bordeaux"";""Paris"";""Versailles""}=B2)))"
Range("A1:B10000").AdvancedFilter Action:=xlFilterInPlace,
CriteriaRange:=[I1:I2]
[I2].ClearContents
End Sub
Une BD contient des mots-clés dans les colonnes
C:F.
On veut récupérer les lignes qui contiennent un mot-clé
appartenant à une liste
Filtre ensemble
de mots-clés
Filtre ensemble
de mots-clés 2
En A2,nous avons la formule:
=SOMMEPROD(ESTNUM(CHERCHE(liste;SUBSTITUE(BD!C2:F2;" ";"")))*(liste<>""))>0
La macro est
Sub FiltreListe()
Sheets("bd").Range("A1").CurrentRegion.AdvancedFilter
Action:=xlFilterInPlace, _
CriteriaRange:=Range("A1:A2"),
Unique:=False
End Sub
Autre méthode
-Fonctionne pour tout type de BD
-Calcule tous les mots clés de la BD
-Choix intuitif des mots clés dans des comboboxs
-Affichage des résultats dans une ListBox
Filtre ensemble de mots-clés form OU ComboBox
Ici l'opérateur saisit des mots-clés séparés par le caractère espace
Filtre
ensemble de mots-clés form OU TextBox
Filtre ensemble
de mots-clés form ET ComboBox
Filtre
ensemble de mots-clés form ET TextBox
Filtre les noms qui commencent par A, C, D, K, P, Z
Sub Filtre2()
Range("I2").Formula = "=SUMPRODUCT(--(({""A"";""C"";""D"";""K"";""P"";""Z""}=LEFT(A2,1))))"
Range("A1:A100").AdvancedFilter Action:=xlFilterInPlace,
CriteriaRange:=[I1:I2]
[I2].ClearContents
End Sub
Sub Filtre()
Tbl = Array("A", "C", "D", "K",
"P", "Z")
[I1] = [A1]
[I2].Resize(UBound(Tbl) + 1) = Application.Transpose(Tbl)
Range("A1:A100").AdvancedFilter Action:=xlFilterInPlace,
CriteriaRange:=[I1].Resize(UBound(Tbl) + 2)
[I1].Resize(UBound(Tbl) + 3).ClearContents
End Sub
Autre exemple
Private Sub B_filtre_Click()
If Me.TextBox1 <> "" Then
Tbl = Split(Me.TextBox1, " ")
[F1] = [B1]
For i = LBound(Tbl) To UBound(Tbl): Tbl(i) = "*"
& Tbl(i) & "*": Next i
[F2].Resize(UBound(Tbl) + 1) = Application.Transpose(Tbl)
[A1:B10000].AdvancedFilter Action:=xlFilterInPlace,
CriteriaRange:=[F1].Resize(UBound(Tbl) + 2)
End If
End Sub
Filtre de non appartenance à un ensemble
On veut la liste des adresses ne contenant pas rue,avenue,impasse.Le champ Liste contient des cellules vides.
Filtre
Non correspondance Liste
Filtre non ensemble
de villes
Filtre non ensemble
de mots
=SOMMEPROD(ESTNUM(CHERCHE(Liste;$C10))*(Liste<>""))=0
Pour avoir la liste des adresses ne contenant pas le mot rue.
=NB.SI(C2;"*rue*")=0
Recherche d'un mot dans plusieurs colonnes discontinues
Filtre les lignes contenant le mot en B2 présent en colonne B ou D ou E
En A2: =OU(ESTNUM(CHERCHE($B$2;B6));ESTNUM(CHERCHE($B$2;D6));ESTNUM(CHERCHE($B$2;E6)))
Recherche d'un mot dans plusieurs colonnes avec Find
La recherche se fait dans toutes les colonnes de la BD. Le filtrage est obtenu en masquant les lignes. On peut placer le curseur sur une ligne en cliquant dans la ListBox.
Recherche de contacts
Permet de chercher un nom ou prénom dans les deux colonnes nom et prénom.
Le critère en H2 contient la
formule:
=NB.SI(A2:B2;"*"&Interro!B2&"*")>0
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" Then
Sheets("BD").Range("A1:F10000").AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("BD").Range("H1:H2"),
CopyToRange:=Range("A4:F4")
End If
End Sub
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
Recherche bibliothèque
Donne les titres contenant le mot clé cherché
dans le titre ou le nom de l'auteur.
Un menu déroulant permet de choisir le mot clé cherché.
En F2:=NB.SI(A2:B2;"*"&$D$2&"*")
Recherche
Bibliothèque
Recherche
Biblithèque Inutuitif
Recherche
Biblithèque Inutuitif 2
Recherche
Biblithèque Inutuitif 3
Recherche
Bibli ET
Recherche
Bibli OU
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
Recherche d'un mot clé dans plusieurs colonnes contiguës
Filtre
élaboré colonnes
Filtre élaboré
colonnes 2 mots clés
Filtre élaboré
colonnes2
Filtre
élaboré colonnes3
En J2: =NB.SI(E2:H2;"*"&$J$8&"*")>0
Interrogation multiple
On peut choisir plusieurs mots clés à la fois en I2:I4.
Filtre
Elabore Interro Multiple
Filtre Elabore Interro
Multiple2
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
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))
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 (listes)
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
FiltreEnsemble2
FiltreEtOu2
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
Autre exemple
FiltreEnsemble3
FiltreEnsemble3
Form
FiltreEnsemble3
Form2
Génération de la formule d'extraction avec VBA
FiltreEnsemble3 Form Formule VBA
=((BD!C2 = "Communication")+(BD!C2 = "Environnement")+(BD!C2 = "Réseaux"))*((BD!H2 = "Centre-Ville")+(BD!H2 = "Commune entière")+(BD!H2 = "Bourg"))*((BD!I2 = "Cabinet du Maire")+(BD!I2 = "Cabinet du Maire / Communication"))
Private Sub b_extrait_Click()
Set f = Sheets("bd")
formule = "="
témoin = False
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) Then
If Not témoin Then
formule = formule & "(": témoin = True
formule = formule &
"(bd!C2 = """ & ListBox1.List(i) & """)+"
End If
Next i
If témoin Then formule = Left(formule,
Len(formule) - 1) & ")"
'-----
témoin2 = False
For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) Then
If témoin And Not
témoin2 Then formule = formule & "*"
If Not témoin2
Then formule = formule & "(": témoin2 = True
formule = formule &
"(bd!h2 = """ & ListBox2.List(i) & """)+"
End If
Next i
If témoin2 Then formule = Left(formule,
Len(formule) - 1) & ")"
'-----
témoin3 = False
For i = 0 To ListBox3.ListCount - 1
If ListBox3.Selected(i) Then
If (témoin Or témoin2)
And Not témoin3 Then formule = formule & "*"
If Not témoin3
Then formule = formule & "(": témoin3 = True
formule = formule &
"(bd!i2 = """ & ListBox3.List(i) & """)+"
End If
Next i
If témoin Or témoin2 Or témoin3
Then formule = Left(formule, Len(formule) - 1) & ")" Else
formule = True
[A2] = formule
f.[A1:J65000].AdvancedFilter Action:=xlFilterCopy,
CriteriaRange:=[A1:A2], CopyToRange:=[A17:J17]
End Sub
Sélection multiple en cascade & extraction
Recherche d'un profil
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
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
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
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
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
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
Menu déroulant avec les noms des 30 premières lignes de la BD
Filtre les lignes de la BD en fonction de l'utilisateur
Filtre & présentation
Création Onglets rapide (0,75 sec pour 32.000 lignes)
-Sachant que la BD est triée par code
.On mémorise dans la variable premier la position
du premier item du bloc
.Dans une boucle, on recherche la position du dernier item du
bloc
.On copie ce bloc dans un nouvel onglet
f.Cells(1+ Premier, 1).Resize(i - Premier - 1, Ncol).Copy [A2]
Création
Onglets rapide
Création Onglets
rapide avec 2 critères
Création
Onglets Compare
Sub Extrait()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("BD").Copy Before:=Sheets(1)
Set f = Sheets(1)
Ncol = 3
' Adapter ou Ncol=f.[A1].CurrentRegion.Columns.Count
colCritère = 2 ' adapter
Derlig = f.[a65000].End(xlUp).Row
Set Rng = f.Cells(2, 1).Resize(Derlig, Ncol)
Rng.Sort key1:=f.Cells(2, colCritère)
TblCrit = f.Cells(2, colCritère).Resize(Derlig - 1)
i = 1: Premier = 1
Do While i <= UBound(TblCrit)
code = TblCrit(i, 1)
Do While TblCrit(i, 1) = code
i = i + 1: If i > UBound(TblCrit)
Then Exit Do
Loop
On Error Resume Next: Sheets(code).Delete: On
Error GoTo 0
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = code
f.Cells(1 + Premier, 1).Resize(i - Premier, Ncol).Copy
[A2]
f.Cells(1, 1).Resize(, Ncol).Copy [A1]
Premier = i
Loop
Sheets(1).Delete
End Sub
Filtre BD 2 groupes juxtaposés
La BD n'est pas normalisée: 2 groupes sont juxtaposés. On veut néanmoins utiliser le filtre élaboré.
=ET(SI($B$3<>"";B6=$B$3;VRAI)+SI($B$3<>"";H6=$B$3;VRAI);NB.SI(C6;"*"&$C$3&"*")+NB.SI(I6;"*"&$C$3&"*");
NB.SI(D6;"*"&$D$3&"*")+NB.SI(J6;"*"&$D$3&"*");
NB.SI(F6;"*"&$E$3&"*")+NB.SI(L6;"*"&$E$3&"*");NB.SI(G6;"*"&$F$3&"*")+NB.SI(M6;"*"&$F$3&"*"))
Filtre BD 2 groupes
Création d'ongets à partir d'une BD et d'un modèle
Création onglets classe modèle
Sub Extrait()
Set f = Sheets("BD")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
f.[L1] = f.[E1] ' colonne critère (adapter)
'--- Liste des ID
f.[A1].CurrentRegion.AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=f.[L1], Unique:=True
For Each c In f.Range("L2:L" & f.[L65000].End(xlUp).Row)
' pour chaque ID
f.[L2] = c.Value
On Error Resume Next
Sheets(CStr(c.Value)).Delete
On Error GoTo 0
Sheets("Modèle").Copy
After:=Sheets(Sheets.Count) ' création
ActiveSheet.Name = CStr(c.Value)
'-- extraction
f.[A1].CurrentRegion.AdvancedFilter
Action:=xlFilterCopy, CriteriaRange:=f.[L1:L2], CopyToRange:=[A5:E5]
[A1] = "Classe " & Left(c.Value,
1) & "eme"
[A2] = c.Value
Next c
f.Select
End Sub
Recopie des titres de la BD
Pour maintenir la cohérence des titres de la BD avec les titres du critère et de l'extraction, nous recopions les titres de la BD.
Sub Extrait()
[Tableau1[#all]].Rows(1).Copy Sheets("accueil").[A1]
[Tableau1[#all]].Rows(1).Copy Sheets("accueil").[A5]
[Tableau1[#all]].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=
_
[A1].Resize(2, [tableau1].Columns.Count), CopyToRange:=
_
[A5].Resize(, [tableau1].Columns.Count),
Unique:=False
End Sub
Filtre élaboré 2 critères
Filtre
élaboré 2 critères
Filtre élaboré
2 critères combobox intuitif
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([A2:B2], Target) Is Nothing And Target.Count
= 1 Then
[A5:D50000].AdvancedFilter Action:=xlFilterCopy,
CriteriaRange:=[d1:d2], _
CopyToRange:=Sheets("result").[A1:D1],
Unique:=False
Sheets("result").[a1].CurrentRegion.Sort
key1:=Sheets("result").[c2], Order1:=xlDescending, Header:=xlYes
End If
End Sub
Filtre avancé (élaboré) multi-critères
Filtre
élaboré multi-critères
Filtre élaboré
entre 2 dates
Filtre élaboré
Multi-critères 2
La fomule du ctitère en E2 est:
=ET(SI($C$1="";VRAI;$C$1=BD!G2);
SI($C$2="";VRAI;$C$2=BD!I2);
SI($C$3="";VRAI;$C$3=BD!W2);
SI($C$4="";VRAI;$C$4=BD!J2);
SI($C$5="";VRAI;BD!N2=$C$5);
SI($C$6="";VRAI;BD!P2=$C$6); SI(ET($C$7<>"";$C$8<>"");ET(BD!K2>=$C$7;BD!K2<=$C$8);SI(ET($C$7<>"";$C$8="");BD!K2>=$C$7;SI(ET($C$7="";$C$8<>"");BD!K2<=$C$8;VRAI))))
La macro d'extraction
Sub Extrait2()
Sheets("DEMANDES").Range("A1:AM10000").AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("critères").Range("E1:E2"),
CopyToRange:=Range( _
"Résultats!Extract"), Unique:=False
End Sub
Filtre suivant une couleur MFC
Sub filtre()
Range("A1:A1000").AdvancedFilter Action:=xlFilterInPlace,
CriteriaRange:= Range("D1:D2"), Unique:=False
End Sub
Sub tout()
On Error Resume Next
ActiveSheet.ShowAllData
End Sub
Function couleurMFC(cel)
couleurMFC = cel.DisplayFormat.Interior.ColorIndex
End Function