Le filtre automatique

Accueil

Statistiques
Supprimer filtrage
Filtre auto chaîne
Filtre sur dates
Filtre suivant une liste
Filtre intersection ensembles
Recherche intuitive de plusieurs mots
Suppression zone filtrée
Protection
Evénement sur modification de filtre
NBSI sur zone filtrée
Somme conditionnelle sur zone filtrée
Occurences uniques sur zone filtrée
Première valeur zone filtrée
NB.SI sur zone filtrée
RechercheV sur zone filtrée
Copie d'une zone Filtrée
Choix des items dans une ListBox
Parcours des éléments visibles
Transfert zone filtrée dans un Array
Transfert zone filtrée dans ListBox
Liste des lignes filtrées
MFC sur zone filtrée
Fonctions personnalisées
Sélection inversée
Impression du filtre
Liste avec plus de 1000 éléments
Filtre sur couleur
Filtre images
Créer un evennement après un choix
Filtre contient mot-clé
Filtre en fonction du nom d'utilisateur

-Suppression de lignes
-Affiche les lignes du client sélectionné
-TCD sur zone filtrée
-Choix lettre
-Exemple congés
-Cacher colonnes vides
-Filtre shapes
-Filtre lettre
-Filtre auto avec choix dans un formulaire



 

 

 

Statistiques sur une zone filtrée

Filtre Automatique Synthèse

La fonction sous-total donne le nombre de lignes filtrées, la somme d’une colonne, la moyenne,…

  • =SOUS.TOTAL(3;A11:A1000)            nombre de lignes filtrées
  • =SOUS.TOTAL(9;D11:D1000)           somme des lignes filtrées
  • =SOUS.TOTAL(1;D11:D1000)           moyenne des lignes filtrées

Activer le mode filtre automatique

Active le mode Filtre automatique s'il n'est pas actif

Sheets(1).[A10].AutoFilter      ' la BD commence en [A10]

Teste si le filtrage est activé et l'active s'il ne l'est pas

If Not Sheets(1).AutoFilterMode Then Sheets(1).[A10].AutoFilter

Désactiver le mode filtre automatique

If Sheets(1).AutoFilterMode Then Sheets(1).[A10].AutoFilter

Supprime le filtrage pour un champ

[A1].AutoFilter Field:=1

Supprime le filtrage pour tous les champs

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

modeFiltre=Sheets(1).AutoFilterMode   ' indique si le mode filtre automatique est actif
champFiltré=Sheets(1).FilterMode        ' indique si au moins un champ est filtré

Filtre automatique sur chaîne

Sur cet exemple, l'opérateur saisi un nom de rue en B2.

Filtre Auto Chaîne
Filtre Auto Chaîne intuitif Textbox
Filtre Auto Chaîne intuitif ComboBox

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$B$2" And Target.Count = 1 Then [A5].AutoFilter field:=4, Criteria1:="*" & [b2] & "*"
End Sub

Filtre automatique sur dates

Ici, nous analysons les différents cas de filtre sur date:une date, intervalle, année,..

Filtre sur une date

En fonction de la version d'Excel, la date n'est pas formatée de la même façon.

FiltreDate

Sub filtre1Date()
   If Val(Application.version) >= 12 Then
      [A5].AutoFilter field:=5, Criteria1:=Format([A2], "dd/mm/yyyy")
   Else
      [A5].AutoFilter field:=5, Criteria1:=Format([A2], "mm/dd/yyyy")
  End If
End Sub

Sub filtreDateInputBox()
  d = InputBox("Date")
  If Val(Application.version) >= 12 Then
     [A5].AutoFilter field:=5, Criteria1:=Format(d, "dd/mm/yyyy")
  Else
    [A5].AutoFilter field:=5, Criteria1:=Format(d, "mm/dd/yyyy")
  End If
End Sub

Filtre >=date

Sub filtreSup1Date()
  [A5].AutoFilter field:=5, Criteria1:=">=" & CDbl(CDate("21/10/1970"))
  ou [A5].AutoFilter field:=5, Criteria1:=">=" & "10/21/1970"
  ou [A5].AutoFilter field:=5, Criteria1:=">=" & CDbl(Range("A2"))
  ou [A5].AutoFilter field:=5, Criteria1:=">=" & Range("A2").Value2
  ou [A5].AutoFilter field:=5, Criteria1:=">=" & Format(Range("A2"), "mm/dd/yyyy")
  ou [A5].AutoFilter field:=5, Criteria1:=">=" & CDbl(CDate("21/10/1970") + 30)
  ou [A5].AutoFilter field:=5, Criteria1:=">=" & CDbl(Date)
  ou [A5].AutoFilter field:=5, Criteria1:=">=" & Format(Date, "mm/dd/yyyy")
  ou [A5].AutoFilter field:=5, Criteria1:=">=" & CDbl(Date + 30)
End Sub

Filtre entre 2 dates

Sub filtre2Dates()
  [A5].Selection.AutoFilter Field:=5, _
     Criteria1:=">" & Format(Range("E1"), "mm/dd/yyyy"), Operator:=xlAnd, _
     Criteria2:="<=" & Format(Range("E2"), "mm/dd/yyyy")
End Sub

ou

Sub filtre2Dates()
  [A5].AutoFilter field:=5, _
     Criteria1:=">=" & CDbl(Range("E1")), Operator:=xlAnd, _
     Criteria2:="<=" & CDbl(Range("E2"))
End Sub

ou

Sub filtre2Dates()
  [A5].AutoFilter field:=5, _
     Criteria1:=">=" & Range("E1").Value2, Operator:=xlAnd, _
     Criteria2:="<=" & Range("E2").value2
End Sub

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

Autre exemple

FiltreDate

Sub filtre2Dates()
  [A4].AutoFilter Field:=1, Criteria1:=">=" & CDbl(Range("c1"))
  [A4].AutoFilter Field:=2, Criteria1:="<=" & CDbl(Range("c2"))
End Sub

Filtre entre 2 dates à partir d'un formulaire

FiltreAuto2Dates

Private Sub Bfiltre_Click()
  If Not IsDate(Me.date_début) Or Not IsDate(Me.date_fin) Then Exit Sub
  [A1].AutoFilter Field:=3, Criteria1:=">=" & Format(CDate(Me.date_début), "mm/dd/yy"), _
     Operator:=xlAnd, Criteria2:="<=" & Format(CDate(Me.date_fin), "mm/dd/yy")
End Sub

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

Filtre sur une année

L’année est saisie dans un formulaire.

FiltreAnnée

Private Sub b_filtre_auto_Click()
  [A1].AutoFilter field:=2, _
    Criteria1:=">=" & "1/1/" & Me.an, Operator:=xlAnd, Criteria2:="<=" & "12/31/" & Me.an
End Sub

ou

Private Sub b_filtre_auto2_Click()
   [A1].AutoFilter field:=2, _
     Criteria1:=">=" & CDbl(DateSerial(Me.an, 1, 1)), Operator:=xlAnd, _
        Criteria2:="<=" & CDbl(DateSerial(Me.an, 12, 31))
End Sub

Filtre semaine passée

FiltreAutoSemaine

Sub filtreSemaine()
    [A1].AutoFilter field:=2, Criteria1:=">=" & CDbl(Date - 7), Operator:=xlAnd
End Sub

Exemple

La colonne C contient les dates de congés sous la forme: Du 1/2/2007 au 7/2/2007
On veut la liste des personnes qui étaient en congés à la date indiquée en G2.

En D2: =DATEVAL(STXT(C2;4;CHERCHE("au";C2)-4))
En E2: =DATEVAL(STXT(C2;CHERCHE("au";C2)+3;99))

- FiltreCongés -

Sub filtre1date()
   [A1].AutoFilter Field:=4, Criteria1:="<=" & CDbl(Range("G2")), Operator:=xlAnd
   [A1].AutoFilter Field:=5, Criteria1:=">=" & CDbl(Range("G2")), Operator:=xlAnd
End Sub

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

Filtre suivant une liste (2007+)

FiltreListe

Sub FiltreListe()
  a = Range("E2:E" & [E65000].End(xlUp).Row).Value
  Dim b(): ReDim b(1 To UBound(a))
  For i = 1 To UBound(a)
     b(i) = CStr(a(i, 1))
  Next i
  ActiveSheet.Range("$A$1:$B$100").AutoFilter Field:=2, Criteria1:=b, Operator:=xlFilterValues
End Sub

Autre exemple

Le choix des lignes à filtrer se fait dans un formulaire.

Filtre Sélection Multiple

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  On Error Resume Next
  ActiveSheet.ShowAllData
  On Error GoTo 0
  Me.ListBox1.List = f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value
  Me.ListBox1.MultiSelect = fmMultiSelectMulti
End Sub

Private Sub B_go_Click()
  Dim a()
  n = 0
  For i = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(i) Then
      n = n + 1: ReDim Preserve a(1 To n)
      a(n) = Me.ListBox1.List(i)
    End If
  Next i
  f.[a1].AutoFilter Field:=1, Criteria1:=a, Operator:=xlFilterValues
  Unload Me
End Sub

Autre Exemple

Sub VilesMultiples()
  Dim a(1 To 3)
  a(1) = "Paris"
  a(2) = "Lyon"
  a(3) = "Marseille"
  ActiveSheet.Range("$A$1:$C$10").AutoFilter Field:=2, Criteria1:=a, Operator:=xlFilterValues
End Sub

Autre Exemple

Sub DatesMultiples()
  Dim a(1 To 6)
  a(1) = 2: a(2) = "10/20/2012"         ' 2:date entière    1:Mois     0:Année
  a(3) = 2: a(4) = "10/21/2012"
  a(5) = 2: a(6) = "12/13/2012"
  ActiveSheet.Range("$A$1:$C$10").AutoFilter Field:=3, Operator:=xlFilterValues, Criteria2:=a
End Sub

Intersection d'ensembles

Donne l'intersection des ensembles Ville,Qualif

Filtre Auto Intersection Ensemble

Sub Filtre()
  Application.ScreenUpdating = False
  On Error Resume Next
  ActiveSheet.ShowAllData
  n = Application.CountA([A2:A5])
  If n > 0 Then
    Tbl = Application.Transpose([A2].Resize(n))
    ActiveSheet.[A8].AutoFilter Field:=3, Criteria1:=Tbl, Operator:=xlFilterValues
  End If
  n = Application.CountA([C2:C5])
  If n > 0 Then
     Tbl = Application.Transpose([C2].Resize(n))
     ActiveSheet.[A8].AutoFilter Field:=5, Criteria1:=Tbl, Operator:=xlFilterValues
  End If
End Sub

Recherche intuitive de plusieurs mots

Filtre les lignes qui contiennent les mots cherchés dans un libellé au fur et à mesure de la frappe des caractères.

Filtre recherche plusieurs mots textbox
Filtre recherche plusieurs mots combobox
Filtre recherche code
Form ComboBox Intuitif pilote Filtre Automatique2.xls

Private Sub TextBox1_Change()
  clé = "*" & Replace(Me.TextBox1, " ", "*") & "*"
  ActiveSheet.Range("$b$4:$d$1000").AutoFilter Field:=1, Criteria1:=clé
End Sub

Private Sub B_tout_Click()
  On Error Resume Next
  ShowAllData
End Sub

Suppression des lignes filtrées

Supprime les lignes visibles

Sur l'exemple, nous supprimons les lignes filtrées.

SupLignesFiltrées

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

Suppression de lignes

Sur cet exemple, on filtre les lignes du service2 avant de les supprimer.

- FiltreAutoSupLignes -

Sub supService2()
  [C1].AutoFilter Field:=2, Criteria1:="service2"
   Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase"). _
   Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
   ActiveSheet.ShowAllData
End Sub

Suppression des dates < an-2

Sub filtreSup()
  [A1].AutoFilter field:=4, Criteria1:="<=" & _
     CDbl(DateSerial(Year(Date) - 2, Month(Date), Day(Date)))

    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
End Sub

Protection feuille et filtre automatique

Protège la feuille mais autorise le filtre automatique.

Filtre Auto Protection

Sub auto_open()
     Sheets(1).EnableAutoFilter = True
     Sheets(1).Protect Contents:=True, UserInterfaceOnly:=True
End Sub

Evénement sur modification de filtre

Pour déclencher un évenement sur une modification de filtre, écrire une formule sous-total dans la feuille de la BD et utiliser l'événement Calculate

Evénnement Filtre

=SOUS.TOTAL(3;A11:A1000)

Private Sub Worksheet_Calculate()
  For Each n In ActiveWorkbook.Names
    If n.Name = "mémoNB" Then trouvé = True
  Next n
  If Not trouvé Then ActiveWorkbook.Names.Add Name:="mémoNB", RefersTo:="=" & [B2].Value
  If [B2] <> [mémoNB] Then
     MsgBox "modif"
     ActiveWorkbook.Names.Add Name:="mémoNB", RefersTo:="=" & [B2].Value
   End If
End Sub

Nombre de lignes filtrées/Filtre auto activé

Compte Zone Filtrée
Compte Zone Filtrée2

n = Application.Subtotal(3, [A2:A1000])
x = Sheets(1).AutoFilterMode         ' filtre auto activé
y = Sheets(1).FilterMode               ' champ filtré

Somme conditionnelle sur une zone filtrée

On veut la somme des montants en monnaie Euro.

Somme Zone Filtrée

=SOMMEPROD((SOUS.TOTAL(9;INDIRECT("b"&LIGNE(B2:B1000)))*(A2:A1000="Eur")))

ou

=SOMMEPROD((SOUS.TOTAL(9;DECALER($B$2;LIGNE(2:1000)-2;0)))*(A2:A1000="Eur"))

Première valeur d'un filtre

=INDEX(A2:A1000;EQUIV(1;(SOUS.TOTAL(3;INDIRECT("a"&LIGNE(2:1000))));0))
Valider avec maj+ctrl+entrée

Première ligne:
=EQUIV(1;(SOUS.TOTAL(3;INDIRECT("A"&LIGNE(2:1000))));0)+1
Valider avec maj+ctrl+entrée

Dernière ligne:
=MAX((SOUS.TOTAL(3;INDIRECT("A"&LIGNE(2:1000)))<>0)*LIGNE(2:1000))
Valider avec maj+ctrl+entrée

NB.SI sur une zone filtrée

On veut le nombre de Dupont (E2) dans la zone filtrée.

=SOMME(SI(Nom=E2;SOUS.TOTAL(3;INDIRECT("A"&LIGNE(Nom)))))
Valider avec maj+ctrl+entrée

FiltreAutoNbSi

ou

=SOMME(SOUS.TOTAL(3;DECALER(Nom;LIGNE(INDIRECT("1:"&LIGNES(Nom)))-1;;1))*(Nom=E2))
Valider avec maj+ctrl+entrée

Avec fonction personnalisée VBA

=NbSsiVisibles(A2:A25;"toto")

Function NBSIVisibles(champ As Range, valeur)
  Application.Volatile
  For Each c In champ
     If Not c.EntireRow.Hidden And Not c.EntireColumn.Hidden Then
          If c.Value = valeur Then t = t + 1
     End If
  Next c
  NBSIVisibles = t
End Function

RechercheV sur une zone filtrée

RechercheVFiltre
TrouvéFiltre

Function rechVFiltre(champRech As Range, valeur, ChampRetour)
  Application.Volatile
  For i = 1 To champRech.Count
    If Not champRech(i).EntireRow.Hidden Then
       If champRech(i) = valeur Then rechVFiltre = ChampRetour(i): Exit Function
    End If
  Next i
  rechVFiltre = ""
End Function

Occurences uniques sur une zone filtrée

=SOMME(--(FREQUENCE(SI(SOUS.TOTAL(3;INDIRECT("A"&LIGNE(Nom)));EQUIV(Nom;Nom;0));
LIGNE(INDIRECT("1:"&LIGNES(Nom))))>0))
valider avec maj+ctrl+entrée

ou

=SOMME(--(FREQUENCE(SI(SOUS.TOTAL(3;DECALER(Nom;LIGNE(INDIRECT("1:"&LIGNES(Nom)))-1;;1));EQUIV(Nom;Nom;0));LIGNE(INDIRECT("1:"&LIGNES(Nom))))>0))
valider avec maj+ctrl+entrée

FiltreOuccurUniques

Positionnement du curseur sur le premier élément

PositionPremier

Sub positionnePremier()
  Cells([_filterdatabase].Offset(1).SpecialCells(xlCellTypeVisible).Row, 1).Select
End Sub

Sub positionneDernier()
  If [_filterdatabase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count - 1 > 0 Then
    [_filterdatabase].End(xlDown).Select
  End If
End Sub

ou [A1].End(xlDown).Select si la première cellule de la BD est A1

Nombre de lignes filtrées

Sub NbLignes()
  n = [_filterdatabase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count - 1
  MsgBox n
End Sub

Sub LigneDernier()
  If [_filterdatabase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count - 1 > 0 Then
     derlig = [_filterdatabase].End(xlDown).Row
     MsgBox derlig
   End If
End Sub

Parcours des élements visibles

ParcoursVisibles

Sub parcoursItemsVisibles()
  For Each c In [_FilterDataBase].Resize(, 1).SpecialCells(xlCellTypeVisible)
    MsgBox c.Value & " " & c.Address
  Next c
End Sub

Transfert dans un tableau

Transfert Array

Sub TransfertTableau()
  Sheets.Add
  Sheets("BD").Range("_FilterDataBase").Offset(1).SpecialCells(xlCellTypeVisible).Copy [A1]
  a = [A1].CurrentRegion
  Application.DisplayAlerts = False
  ActiveSheet.Delete
End Sub

Sans feuille intermédiaire

Sub TransfertTableau()
  NbCol = [_FilterDataBase].Columns.Count
  Dim Liste(): ReDim Liste(1 To [_FilterDataBase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count, 1 To NbCol)
  For Each c In [_FilterDataBase].Offset(1).Resize(, 1).SpecialCells(xlCellTypeVisible)
     i = i + 1
     For k = 1 To NbCol: Liste(i, k) = c.Offset(, k - 1): Next k
  Next c
  Sheets(2).[A1].Resize(UBound(Liste), UBound(Liste, 2)) = Liste
End Sub

ou

Sub TransfertTableau3()
  Set Rng = [_FilterDataBase]
  Dim tmp(): ReDim tmp(1 To [_FilterDataBase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count)
  For Each c In [_FilterDataBase].Resize(, 1).Offset(1).SpecialCells(xlCellTypeVisible)
     i = i + 1: tmp(i) = c.Row - Rng.Row + 1
  Next c
  ReDim Preserve tmp(1 To UBound(tmp) - 1)
  a = Application.Index(Rng, Application.Transpose(tmp), Application.Transpose(Evaluate("Row(1:" & Rng.Columns.Count & ")")))
  Sheets(2).[A1].Resize(UBound(a), UBound(a, 2)) = a
End Sub

Transfert dans une ListBox

ListBox

Private Sub UserForm_Initialize()
  Sheets.Add
  Sheets("BD").Range("_FilterDataBase").Offset(1).SpecialCells(xlCellTypeVisible).Copy [A1]
  Me.ListBox1.List = [A1].CurrentRegion.Value
  Application.DisplayAlerts = False
  ActiveSheet.Delete
  For i = 1 To 3
     Me("label" & i) = Sheets("bd").Cells(1, i)
  Next i
End Sub

Sans feuille intermédiaire

ListBox

Private Sub UserForm_Initialize()
  Dim Liste(): ReDim Liste(1 To [_FilterDataBase].Offset(1).Resize(, 1).SpecialCells(xlCellTypeVisible).Count, 1 To 2)
  For Each c In [_FilterDataBase].Offset(1).Resize(, 1).SpecialCells(xlCellTypeVisible)
    i = i + 1: Liste(i, 1) = c: Liste(i, 2) = c.Offset(, 1)
  Next c
  Me.ComboBox1.List = Liste
End Sub

ou pour toutes les colonnes

Private Sub UserForm_Initialize()
  Set Rng = [_FilterDataBase]
  Dim tmp(): ReDim tmp(1 To [_FilterDataBase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count)
  For Each c In [_FilterDataBase].Resize(, 1).Offset(1).SpecialCells(xlCellTypeVisible)
     i = i + 1: tmp(i) = c.Row - Rng.Row + 1
  Next c
  Me.ComboBox1.List = Application.Index(Rng, Application.Transpose(tmp), Application.Transpose(Evaluate("Row(1:" &   Rng.Columns.Count & ")")))
End Sub

Transfert zone filtrée Colonnes 2 et 4

Sub transfertCol_2et4()
  Sheets(1).Range("_FilterDataBase").Columns(2).SpecialCells(xlCellTypeVisible).Copy Sheets(2).[a1]
  Sheets(1).Range("_FilterDataBase").Columns(4).SpecialCells(xlCellTypeVisible).Copy Sheets(2).[b1]
End Sub

Transfert zone filtrée Colonnes 2,4,3,1

Sub transfertCol_2_4_3_1()
  Sheets(1).Range("_FilterDataBase").SpecialCells(xlCellTypeVisible).Copy Sheets(2).[a1]
  Set Rng = Sheets(2).[a1].CurrentRegion
  Sheets(2).[a1].Resize(Rng.Rows.Count, 4) = Application.Index(Rng, Evaluate("Row(1:" & Rng.Rows.Count & ")"), Array(2, 4, 3, 1))
End Sub

MFC sur zone filtrée

On veut colorier une ligne sur 2.

-Sélectionner A2:B1000
-Format/MFC/La formule est:
=ET(MOD(SOUS.TOTAL(3;$A2:$A$1000);2)=0;A2<>"")

Liste des valeurs filtrées

En A2
=SI(LIGNES($1:1)<=SOUS.TOTAL(3;Nom);
INDEX(Nom;PETITE.VALEUR(SI(SOUS.TOTAL(3;INDIRECT("A"&LIGNE(Nom)))=1;LIGNE(INDIRECT("1:"&LIGNES(Nom))));LIGNES($1:1)));"")
Valider avec Maj+ctrl+entrée

ListeLignesFiltrées

Copie d'une zone filtrée

On veut copier dans une nouvelle feuille les lignes qui correspondent à un critère sur le code. Par exemple,
on veut tous les codes qui commencent par BJ.

Sub ExtraitVersAutreFeuille()
  critere = InputBox("Critere?")
  If critere = "" Then Exit Sub
  [A1].AutoFilter Field:=1, Criteria1:=critere & "*"
  Sheets.Add after:=Sheets(Sheets.Count)
  ActiveSheet.Name = critere
  Sheets("BD").Range("_FilterDataBase").SpecialCells(xlCellTypeVisible).Copy [A1]
  Cells.EntireColumn.AutoFit
  Sheets("BD").ShowAllData
End Sub

CopieZoneFiltrée

Choix des items dans une ListBox

L'opérateur choisi les items dans une ListBox

Choix Items ListBox

Sub auto_open()
  Set d = CreateObject("scripting.dictionary")
  Set f = Sheets("bd")
  Set Rng = f.[c9].Offset(1).Resize(1000)
  For Each c In Rng
    If c <> "" Then d(c.Value) = ""
  Next
  a = d.keys
  Tri a, LBound(a), UBound(a)
  f.ListBox1.List = a
  f.ListBox1.Height = 65
End Sub

Private Sub ListBox1_Change()
  Dim b()
  n = 0
  For i = 0 To Me.ListBox1.ListCount - 1
     If Me.ListBox1.Selected(i) Then
         n = n + 1: ReDim Preserve b(1 To n): b(n) = Me.ListBox1.List(i)
     End If
  Next i
  If n > 0 Then
     ActiveSheet.Range("$A$9:$G$1000").AutoFilter Field:=3, Criteria1:=b, Operator:=xlFilterValues
  Else
     ActiveSheet.Range("$A$9:$G$1000").AutoFilter Field:=3
  End If
  Calculate
End Sub

Affiche les images filtrées

La fonction SousTotal() en A2 permet de déclencher l'événement Calculate après une modifcation du filtre et donc d'activer la fonction Affiche().

FiltreAutoShape

Function affiche(champ As Range)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  For Each s In f.Shapes
    If UCase(Left(s.Name, 3)) = "IMG" Then s.Visible = False
  Next
  For Each c In champ
    On Error Resume Next
    If Not c.EntireRow.Hidden Then f.Shapes("img" & c.Value).Visible = True
  Next c
  affiche = ""
End Function

Fonctions personnalisées

Filtre Auto Fonctions Perso

Indique si un champ est filtré

Function ChampActif(c)
  Application.Volatile
  ChampActif = Sheets(Application.Caller.Parent.Name).AutoFilter.Filters.Item(c.Column -   Sheets(Application.Caller.Parent.Name).Range("_FilterDataBase").Column + 1).On
End Function

Pour appliquer une MFC sur les titres:
-Sélectionner A1:G1
-Format/mise en forme conditionnelle/La formule est
=ChampActif(A1)

Cette fonction indique si le filtre automatique a été activé.

Function Estfiltré()
  Application.Volatile
  Estfiltré = IIf(Sheets(Application.Caller.Parent.Name).AutoFilterMode, "Filtré", "pas filtré")
End Function

Cette fonction indique si des lignes sont filtrées.

Function EstSelectionFiltre()
  Application.Volatile
  EstSelectionFiltre = Sheets(Application.Caller.Parent.Name).FilterMode
End Function

La fonction perso FiltreActuel(feuille;noCol) donne l’expression du filtre pour la colonne

Function FiltreActuel(feuille, c, Optional typeCol As String)
  Application.Volatile
  col = c.Column - Sheets(feuille).Range("_FilterDataBase").Column + 1
  If Sheets(feuille).FilterMode Then
    If Sheets(feuille).AutoFilter.Filters.Item(col).On Then
      operi = Sheets(feuille).AutoFilter.Filters.Item(col).Operator
      On Error Resume Next
      temp = Sheets(feuille).AutoFilter.Filters.Item(col).Criteria1
      If Err = 0 Then
         If operi <> 7 Then
           If Left(temp, 2) = ">=" Or Left(temp, 2) = "<=" Then
              o = Left(temp, 2): n = Mid(temp, 3)
           Else
              If Left(temp, 1) = "=" Or Left(temp, 1) = ">" Or Left(temp, 1) = "<" Then
                 o = Left(temp, 1): n = Mid(temp, 2)
              Else
                 n = temp
              End If
          End If
          If typeCol = "D" Then n = Format(n, "dd/mm/yy")
          temp = o & n
          tmp = temp
       Else
          tmp = "="
          For i = LBound(temp) To UBound(temp)
             tmp = tmp & Mid(temp(i), 2) & "+"
          Next i
          tmp = Left(tmp, Len(tmp) - 1)
          FiltreActuel = tmp
          Exit Function
       End If
     End If
     '---
     If operi = 1 Then oper = " ET "
     If operi = 2 Then oper = " OU "
     If operi = 7 Then
        a = Sheets(feuille).AutoFilter.Filters.Item(col).Criteria2
        FiltreActuel = "?"
     Else
        On Error Resume Next
        Err = 0
        temp2 = Sheets(feuille).AutoFilter.Filters.Item(col).Criteria2
        If Err = 0 Then
           If Left(temp2, 2) = ">=" Or Left(temp2, 2) = "<=" Then
           o = Left(temp2, 2): n = Mid(temp2, 3)
        Else
           If Left(temp2, 1) = "=" Or Left(temp2, 1) = ">" Or Left(temp2, 1) = "<" _
               Then o = Left(temp2, 1): n = Mid(temp2, 2)
        End If
        If typeCol = "D" Then n = Format(n, "dd/mm/yy")
        temp2 = o & n
     Else
        oper = ""
     End If
     FiltreActuel = tmp & oper & temp2
   End If
  End If
 Else
    FiltreActuel = ""
  End If
End Function

Place dans l'entête d'impression la requête du filtre

La fonction personnalisée FiltreTotal(feuille) permet d'obtenir l'expression du filtre.

FiltreImprime
FiltreImprime2

Sub imprime()
   ActiveSheet.PageSetup.CenterHeader = "Filtre:" & FiltreTotal("imprime")
   ActiveSheet.PrintPreview
End Sub

Function FiltreTotal(feuille)
  Application.Volatile
  chaine = ""
  For c = 1 To Sheets(feuille).Range("_FilterDataBase").Columns.Count
    If FiltreActuelNo(feuille, c) <> "" Then
      If IsDate(Sheets(feuille).Range("_FilterDataBase").Cells(2, c)) Then
        chaine = chaine & Sheets(feuille).Range("_FilterDataBase").Cells(1, c) & FiltreActuelNo(feuille, c, "D") & " "
      Else
        chaine = chaine & Sheets(feuille).Range("_FilterDataBase").Cells(1, c).Value & FiltreActuelNo(feuille, c) & " "
      End If
    End If
  Next c
  If chaine = "" Then chaine = "Tout"
  FiltreTotal = chaine
End Function

Function FiltreActuelNo(feuille, col, Optional typeCol As String)
  Application.Volatile
  If Sheets(feuille).FilterMode Then
    If Sheets(feuille).AutoFilter.Filters.Item(col).On Then
      temp = Sheets(feuille).AutoFilter.Filters.Item(col).Criteria1
      If Left(temp, 2) = ">=" Or Left(temp, 2) = "<=" Then
        o = Left(temp, 2): n = Mid(temp, 3)
      Else
        If Left(temp, 1) = "=" Or Left(temp, 1) = ">" Or Left(temp, 1) = "<" Then
          o = Left(temp, 1): n = Mid(temp, 2)
        Else
           n = temp
        End If
      End If
      If typeCol = "D" Then n = Format(n, "dd/mm/yy")
        temp = o & n
        '---
        If Sheets(feuille).AutoFilter.Filters.Item(col).Operator Then
           oper = IIf(Sheets(feuille).AutoFilter.Filters.Item(col).Operator = 1, " ET ", " OU ")
           On Error Resume Next
           Err = 0
           temp2 = Sheets(feuille).AutoFilter.Filters.Item(col).Criteria2
           If Err = 0 Then
              If Left(temp2, 2) = ">=" Or Left(temp2, 2) = "<=" Then
                 o = Left(temp2, 2): n = Mid(temp2, 3)
              Else
                 If Left(temp2, 1) = "=" Or Left(temp2, 1) = ">" Or Left(temp2, 1) = "<" _
                    Then o = Left(temp2, 1): n = Mid(temp2, 2)
                 End If
                 If typeCol = "D" Then n = Format(n, "dd/mm/yy")
                   temp2 = o & n
                 Else
                 oper = ""
              End If
           End If
           FiltreActuelNo = temp & oper & temp2
        Else
           FiltreActuelNo = ""
        End If
      Else
        FiltreActuelNo = ""
      End If
End Function

Sélection inversée

Sur cet exemple, l'opérateur peut inverser les choix de villes qu'il a fait

Filtre Auto Inversé

Copie d’une zone filtrée vers une autre feuille et TCD

On veut créer un TCD sur le résultat d'un filtre.

- FiltreAutoTCD -

Nom de champ dynamique :

BDExtraction =DECALER(BDExtrait!$A$1;;;NBVAL(BDExtrait!$A:$A);7)

Dans le TCD, spécifier le nom de champ dynamique BDExtraction

Sub Extrait()
   nf = "BDExtrait"
   Sheets(nf).Cells.ClearContents
   Range("_FilterDataBase").SpecialCells(xlCellTypeVisible).Copy Sheets(nf).[A1]
   Sheets("TCD").PivotTables("Tableau croisé dynamique1").PivotCache.Refresh
   Calculate
End Sub

Sub tout()
   On Error Resume Next
   ActiveSheet.ShowAllData
   Extrait
End Sub

Optionnel:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column <= 7 And Target.Count = 1 Then
     Extrait
  End If
  Calculate
End Sub

Filtre les noms commençant par la lettre choisie

Sur l’exemple, la liste a été réalisée avec la BO boîte à outils contrôles.

FiltreAutoLettre3
FiltreAutoLettre
FiltreAutoLettre2

Sub auto_open()
  ActiveSheet.choix_lettre.AddItem "*"
  For i = 1 To 26
    ActiveSheet.choix_lettre.AddItem Chr(64 + i)
  Next i
End Sub

Private Sub choix_lettre_Change()
    lettre = ActiveSheet.choix_lettre.Value
    critère = "=" & lettre & "*"
    Range("B4").Select
    Selection.AutoFilter Field:=1, Criteria1:=critère
End Sub

Liste avec plus de 1000 éléments

Les listes déroulantes du filtre auto n'affichent que les 1000 premières lignes.
Le Menu crée avec la BO boîte à outils contrôles permet d'afficher + de 1000 lignes

FiltreAutoSup1000
Filtre Auto Sup 1000_2

Sub Auto_Open()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range([A4], [A65000].End(xlUp))
    If Not mondico.Exists(c.Value) Then mondico.Add c.Value, c.Value
  Next c
  Sheets(1).ComboBox1.List = mondico.items
End Sub

Private Sub ComboBox1_Change()
   [A3].AutoFilter field:=1, Criteria1:=ComboBox1
End Sub

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

Filtre sur une couleur

On crée une colonne intermédiaire (couleur).On utilise une fonction perso.

FilreAutoCouleur
Filtre TriCouleur

Créer cette fonction dans un module:

Function CouleurTexte2(c As Range)
   Application.Volatile
   Select Case c.Font.ColorIndex
     Case 3
        CouleurTexte2 = "Rouge"
     Case 4
        CouleurTexte2 = "Vert"
     Case Else
        CouleurTexte2 = "sans"
    End Select
End Function

Pour une maj automatique, utiliser le pinceau pour colorier ou

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Calculate
End Sub

Filtre sur caractères gras

On veut filtrer les lignes en gras. On utilise une fonction perso.
Créer cette fonction dans un module:

Function EstGras(c As Range)
  Application.Volatile
  EstGras = IIf(c.Font.Bold, "Gras", "Maigre")
End Function

FiltreAutoGras

ou

Sub FiltreGras()
  For Each c In Range("a2:A" & [a65000].End(xlUp).Row)
      c.EntireRow.Hidden = Not c.Font.Bold
  Next c
End Sub

Sub tout()
    Cells.Rows.Hidden = False
End Sub

Affiche les lignes du client sélectionné

Le choix du client se fait dans un UserForm

FiltreAutoMasque

Private Sub UserForm_Initialize()
  On Error Resume Next
  ActiveSheet.ShowAllData
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In Range([a2], [A65000].End(xlUp))
    If Not MonDico.Exists(c.Value) Then MonDico.Add c.Value, c.Value
  Next c
  Me.ComboBox1.List = MonDico.items
  'Me.ComboBox1.ListIndex = 0
End Sub

Private Sub ComboBox1_Change()
   [A1].AutoFilter Field:=1, Criteria1:=Me.ComboBox1
End Sub

Cacher les colonnes vides

Sub filtre()
   Cells.EntireColumn.Hidden = False
   Range("_FilterDataBase").SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeBlanks).EntireColumn.Hidden = True
End Sub

Sub tout()
   Cells.EntireColumn.Hidden = False
End Sub

Sélection des nombres supérieurs à une valeur

Sur cet exemple, nous sélectionnons les nombres supérieurs à 10.

[A1].AutoFilter Field:=1, Criteria1:=">=10", Operator:=xlAnd
Range("A2", [A65000].End(xlUp)).SpecialCells(xlCellTypeVisible).Select
ActiveSheet.ShowAllData
[A1].AutoFilter

Pilotage filtre automatique par combobox

Form Pilotage filtre automatique
Form Pilotage filtre automatique sans formulaire

Filtre images

Modifie la propriété Placement. Le filtre auto déplace les images - Filtre auto images -

Sub modifieMove()
  For Each c In ActiveSheet.Shapes
   If c.Type = 13 Then
      c.Placement = xlMoveAndSize
   End If
  Next c
End Sub

Créer un évennement après un choix dans un filtre

On veut le total des montants sans doublons sur une zone filtrée
(sur les résidences)

Ecrire une formule Sous.Total() en I1 par exemple : =SOUS.TOTAL(3;A2:A12)

FiltreSommeSansDoublonsVBA
FiltreSommeSansDoublonsFormule

Private Sub Worksheet_Calculate()
  t = 0
  For Each c In [_FilterDataBase].Offset(1, 1).Resize(, 1).SpecialCells(xlCellTypeVisible)
    If c <> mc Then
      t = t + c.Offset(, 2)
    End If
    mc = c
  Next c
  [d14] = t
End Sub

Filtre lettre

Met en gras et en couleur le bouton appelant

FiltreLettre

Sub appelBoutons2()
  For Each c In ActiveSheet.Shapes
     If c.Type = 8 And Left(c.Name, 4) <> "Drop" Then
      c.TextFrame.Characters(Start:=1, Length:=1).Font.Bold = False
      c.TextFrame.Characters(Start:=1, Length:=1).Font.ColorIndex = 0
    End If
  Next c
  nomshape = Application.Caller
  '[A1] = ActiveSheet.Shapes(nomshape).TextFrame.Characters.Text
  ActiveSheet.Shapes(nomshape).TextFrame.Characters(Start:=1, Length:=1).Font.Bold = True
  ActiveSheet.Shapes(nomshape).TextFrame.Characters(Start:=1, Length:=1).Font.ColorIndex = 3
  '--- Filtre
  lettre = ActiveSheet.Shapes(nomshape).TextFrame.Characters.Text
  critère = "=" & lettre & "*"
  Range("B4").Select
  Selection.AutoFilter Field:=1, Criteria1:=critère
End Sub

Filtre auto avec choix dans un formulaire

Les choix peuvent être fait dans un ordre quelconque.

FormCasCade
FormCasCade MAC
FormCasCade MAC2
FormCasCade2 Mac
FormCasCade3
FormCasCade2ListView
FormCasCade2ListView2
FormCasCadeLiens
FormCasCade6niveaux
Form ComboBox Intuitif pilote Filtre Automatique.xls
Form ComboBox Intuitif pilote Filtre Automatique2.xls

Pilotage filtre automatique

Les programmes ci dessous permettent de piloter des filtres auto à partir de 4 comboboxs:

-Les choix dans les comboboxs se font dans un ordre quelconque
-On peut choisir les colonnes de la BD affectés aux comboboxs.

Form Pilotage filtre automatique
Pilotage filtre automatique sans formulaire avec ComboBoxs
Pilotage filtre automatique sans formulaire avec ComboBoxs 2

Dim f, bd, TabBD(), ColCombo()
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  B_tout_Click
  Set bd = f.Range("A2:F" & f.[A65000].End(xlUp).Row)
  TabBD = bd.Value2
  ColCombo = Array(1, 2, 3, 4) ' A adapter
  For c = 1 To UBound(ColCombo) + 1: ListeCol c: Next c
  For i = 1 To UBound(ColCombo) + 1: Me("label" & i) = f.Cells(1, ColCombo(i - 1)): Next i
End Sub

Sub ListeCol(noCol)
  Set MonDico = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(TabBD)
   ok = True
   For Cb = 0 To UBound(ColCombo)
     ColBD = ColCombo(Cb)
     If Cb + 1 <> noCol Then
        If Not TabBD(i, ColBD) Like Me("comboBox" & Cb + 1) Then ok = False
      End If
   Next Cb
   If ok Then
     tmp = TabBD(i, ColCombo(noCol - 1))
     MonDico(tmp) = ""
   End If
  Next i
  MonDico("*") = ""
  temp = MonDico.keys
  Tri temp, LBound(temp), UBound(temp)
  Me("ComboBox" & noCol).List = temp
End Sub

Private Sub B_tout_Click()
  On Error Resume Next
  ActiveSheet.ShowAllData
  For i = 1 To 4: Me("combobox" & i) = "*": Next i
End Sub

Private Sub ComboBox1_DropButtonClick()
  ListeCol 1
End Sub

Private Sub ComboBox2_DropButtonClick()
  ListeCol 2
End Sub

Private Sub ComboBox3_DropButtonClick()
  ListeCol 3
End Sub

Private Sub ComboBox4_DropButtonClick()
  ListeCol 4
End Sub

Private Sub ComboBox1_Change()
  f.[A1].AutoFilter Field:=ColCombo(0), Criteria1:=Me.ComboBox1
End Sub

Private Sub ComboBox2_Change()
  f.[A1].AutoFilter Field:=ColCombo(1), Criteria1:=Me.ComboBox2
End Sub

Private Sub ComboBox3_Change()
  f.[A1].AutoFilter Field:=ColCombo(2), Criteria1:=Me.ComboBox3
End Sub

Private Sub ComboBox4_Change()
  f.[A1].AutoFilter Field:=ColCombo(3), Criteria1:=Me.ComboBox4
End Sub

Filtre auto contient mot-clé

On veut filtrer les lignes qui contiennent Généreux

FiltreAutoMult

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$2" Then
   ActiveSheet.Range("$C$3:$D$1000").AutoFilter Field:=2, Criteria1:= _
      "=*" & [A2] & "*", Operator:=xlAnd
  End If
End Sub

Ouvrir un classeur avec un filtre sur le nom de l'utilisateur

L'utilisateur ne doit voir que les enregistrements correspondant à son nom d'utilisateur réseau ou du nom d'utilisateur Office.

FiltreAutoUtil
FiltreAutoUtil3

Nom             Date              Montant
boisgontier    01/01/2014     100
dupont          02/01/2014     100
boisgontier    03/01/2014     100
durand          04/01/2014     100

Private Sub Workbook_Open()
  nom = Environ("username") ' nom réseau
  Sheets(1).Cells.AutoFilter Field:=1, Criteria1:=nom
End Sub

ou

Private Sub Workbook_Open()
  nom = Application.UserName ' user office
  Sheets(1).Cells.AutoFilter Field:=1, Criteria1:=nom
End Sub

ou

Private Sub Workbook_Open()
  nom = Application.UserName
  initiales = Application.VLookup(nom, [utilisateurs], 2, False) ' table correspondance
  If Not IsError(initiales) Then
    Sheets(1).Cells.AutoFilter Field:=1, Criteria1:=initiales
   End If
End Sub

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

Exemples

Filtre Automatique Synthèse
Compte Zone Filtrée
Somme Zone Filtrée
Compte Zone Filtrée2
Filtre Auto Protection
Filtre Auto Fonctions Perso
Filtre Auto Sup 1000
Filtre Auto Sup 1000_2
Filtre Auto consolide Onglets
Filtre Auto Paye
Filtre Auto SupLignes
Filtre Auto Masque
FiltreAutoSemaine
filtreTriCouleur.xls