Statistiques sur une zone filtrée
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
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 auto d'un tableau dynamique nommé Tableau1
Sub FiltreTableauDynamique()
[tableau1].AutoFilter Field:=5, Criteria1:="Informaticien"
End Sub
Sub SansFiltreTableauDynamique()
[tableau1].AutoFilter
End Sub
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.
Filtre Date
Filtre Date Pilote Formulaire
Filtre Date ListBox
Filtre Date An Mois
Spécial
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
Filtre 1 mois d'une année
Sub FiltreMoisAn()
mois = 3: an = 2007
ActiveSheet.Range("$A$5:$E$30").AutoFilter Field:=5,
Operator:= _
xlFilterValues, Criteria2:=Array(1, Format(DateSerial(an,
mois, 1), "mm/dd/yyyy"))
End Sub
Filtre mois en cours,précédent,suivant (7,8,9)
ActiveSheet.Range("$A$5:$E$33").AutoFilter Field:=5, Criteria1:=7, Operator:=xlFilterDynamic
Filtre 1 mois Janvier toutes années (21:janvier,22:Février,23:Mars..)
Sub FiltreMarsTousAns()
ActiveSheet.Range("$A$5:$E$33").AutoFilter
Field:=5, Criteria1:=21, Operator:=xlFilterDynamic
End Sub
Filtre semaine en cours,précédent,suivant (4,5,6)
Autre exemple
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
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.
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
Sub filtreSemaine()
[A1].AutoFilter field:=2, Criteria1:=">="
& CDbl(Date - 7), Operator:=xlAnd
End Sub
Filtre avec plusieurs critères sur une colonne
Dans la colonne Date, nous avons des dates mais aussi des
libellés.
Filtre Date An Mois
Spécial
Sub FiltreMois()
mois = [B2]: an = [B1]
moisLib = Format(DateSerial(an, mois, 1), "mmmm-yyyy")
moisLibTot = Format(DateSerial(an, mois, 1), "Total mmmm
yyyy")
dateFin = mois & "/" & Day(DateSerial(an,
mois + 1, 1) - 1) & "/" & an
ActiveSheet.Range("$A$4:$C$10000").AutoFilter Field:=2,
Criteria1:=Array(moisLib, moisLibTot), _
Operator:=xlFilterValues, Criteria2:=Array(1,
dateFin)
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+)
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
Filtre Sélection
Multiple plusieurs colonnes
Dim TblBD(), NbCol, NomTableau
Private Sub UserForm_Initialize()
TblBD = [Tableau1].Value
'--- construction des cases d'options villes
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(TblBD): d(TblBD(i, 3)) = "": Next i
temp = d.keys
Tri temp, LBound(temp), UBound(temp)
Me.ListBox1.List = temp ' Villes triées
B_tout_Click
End Sub
Private Sub ListBox1_Change()
Dim Tbl()
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then
n = n + 1: ReDim Preserve Tbl(1
To n)
Tbl(n) = Me.ListBox1.List(i)
End If
Next i
If n > 0 Then
Sheets("bd").[A1].AutoFilter Field:=3,
Criteria1:=Tbl, Operator:=xlFilterValues
Else
Sheets("bd").[A1].AutoFilter
End If
End Sub
Private Sub B_tout_Click()
Sheets("bd").[A1].AutoFilter
For i = 0 To Me.ListBox1.ListCount - 1
Me.ListBox1.Selected(i) = False
Next i
End Sub
Autre exemple
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
Autre exemple
Filtre
Auto Liste Form
Filtre Elab Liste
Form
Private Sub B_filtre_Click()
If Me.TextBox1 <> "" Then
Tbl = Split(Me.TextBox1, " ")
ActiveSheet.Range("$A$1:$B$10000").AutoFilter
Field:=2, Criteria1:=Tbl, Operator:=xlFilterValues
End If
End Sub
Filtre suivant inverse d'une liste (2007+)
Filtre
Inverse Liste
Filtre Inverse Liste
2
Filtre Inverse Liste
4
Filtre Inverse Liste
Array
Filtre Inverse
Liste Num
Sub FiltreInverseListe()
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
For Each c In Range("E2:E" & [E65000].End(xlUp).Row)
d(c.Value) = ""
Next c
Set d2 = CreateObject("scripting.dictionary")
d2.CompareMode = vbTextCompare
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
If Not d.exists(c.Value) Then d2(c.Value)
= ""
Next c
ActiveSheet.Range("$A$1:$B$100").AutoFilter Field:=2,
Criteria1:=d2.keys, Operator:=xlFilterValues
End Sub
autre exemple avec un tableau structuré
On veut filtrer ce qui est <>1,2,6 en colonne 2 et <> vide en colonne 3
Sub FiltreInverseListe()
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
Liste = Array(1, 2, 6) ' Liste à ne pas sélectionner
For Each c In Liste: d(CStr(c)) = "": Next c
Set d2 = CreateObject("scripting.dictionary") '
liste complémentaire
d2.CompareMode = vbTextCompare
For Each c In [Tbsaisies[Num]]
If Not d.exists(CStr(c.Value)) Then d2(CStr(c.Value))
= ""
Next c
[Tbsaisies].AutoFilter Field:=2, Criteria1:=d2.keys, Operator:=xlFilterValues
[Tbsaisies].AutoFilter Field:=3, Criteria1:="<>"
End Sub
Sub supFiltre()
[Tbsaisies].AutoFilter
End Sub
Filtre auto couleur
On ne veut que les lignes ayant:
-en colonne 4 un code appartenant à liste
-en colonne 6 un code égal à 11
-pas de couleur en colonne 5
Sub filtre()
b = Application.Transpose([liste])
[tableau1].AutoFilter Field:=6, Criteria1:=[serie]
[tableau1].AutoFilter Field:=4, Criteria1:=b, Operator:=xlFilterValues
[tableau1].AutoFilter Field:=5, Operator:=xlFilterAutomaticFontColor
'on ne veut pas des lignes en couleur
End Sub
Filtre par rapport à la cellule active
Filtre par rapport à la cellule active
Sub filtre()
col = ActiveCell.Column
If col <= [A1].CurrentRegion.Columns.Count Then
ActiveSheet.Range("A1").AutoFilter Field:=col,
Criteria1:=ActiveCell
End If
End Sub
Segments
Intersection d'ensembles
Donne l'intersection des ensembles Ville,Qualif
Filtre
Auto Intersection Ensembles
Pilotage
Filtre Auto formulaire
Pilotage
Filtre Auto formulaire 3
Form Filtre
Auto Intersection Ensembles
Consolidation Filtre
Auto Intersection Ensembles
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
Formulaire de modification des lignes filtrées
Formulaire Modification lignes filtrées
Private Sub UserForm_Initialize()
NbCol = [_filterdatabase].Columns.Count
NbLig = [_filterdatabase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count
- 1
NomTableau = "Tableau1"
ActiveWorkbook.Names.Add Name:=NomTableau, RefersTo:=[_filterdatabase].Offset(1)
Dim Liste(): ReDim Liste(1 To NbLig, 1 To NbCol + 1)
For Each c In [_filterdatabase].Offset(1).Resize(, 1).SpecialCells(xlCellTypeVisible)
n = n + 1
If n <= NbLig Then
For k = 1 To NbCol: Liste(n,
k) = c.Offset(, k - 1): Next k
Liste(n, k) = c.Row
End If
Next c
Me.ListBox1.List = Liste
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.
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
Suppressionn des lignes filtrées d'un tableau structuré
Sup Lignes Filtrées tableau structuré
Sub FiltreInverseListe()
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
Liste = Array(1, 2, 6) ' Liste à garder
For Each c In Liste: d(CStr(c)) = "": Next c
Set d2 = CreateObject("scripting.dictionary") '
liste complémentaire
d2.CompareMode = vbTextCompare
For Each c In [Tableau1[Num]]
If Not d.exists(CStr(c.Value)) Then d2(CStr(c.Value))
= ""
Next c
[Tableau1].AutoFilter Field:=2, Criteria1:=d2.keys, Operator:=xlFilterValues
Application.DisplayAlerts = False
[Tableau1].Delete ' suppression des lignes filtrées
[Tableau1].AutoFilter
End Sub
Suppression de lignes
Sur cet exemple, on filtre les lignes du service2 avant de les supprimer.
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.
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
=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.
=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
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
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
Positionnement du curseur sur le premier élément
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
Sub parcoursItemsVisibles()
For Each c In [_FilterDataBase].Resize(, 1).SpecialCells(xlCellTypeVisible)
MsgBox c.Value & " " & c.Address
Next c
End Sub
Transfert dans un tableau
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
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
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
Autre exemple
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
Fonction personnalisée retournant la liste des lignes filtrées
Fonction
Lignes filtrées
Fonction Lignes
filtrées2
-sélectionner A3:G40
=lignesfiltrees("tableau1")
Valider avec maj+ctrl+entrée
Function LignesFiltrees(NomTableau)
Application.Volatile
Set f = Sheets(Range(NomTableau).Parent.Name)
decal = Range(NomTableau).Row - 1
TblE = Range(NomTableau).Value
Ncol = Application.Caller.Columns.Count
Dim TblS()
For j = 1 To Range(NomTableau).Rows.Count
ligne = decal + j
If Not f.Rows(ligne).Hidden Then
n = n + 1
ReDim Preserve TblS(1 To Ncol,
1 To n)
For k = 1 To Ncol: TblS(k, n)
= TblE(j, k): Next k
End If
Next j
ReDim Preserve TblS(1 To Ncol, 1 To Application.Caller.Rows.Count)
LignesFiltrees = Application.Transpose(TblS)
End Function
ou
Function LignesFiltrees1(NomTableau)
Application.Volatile
Ncol = Application.Caller.Columns.Count
Dim TblS()
For Each lig In Range(NomTableau).ListObject.ListRows
If Not lig.Range.EntireRow.Hidden Then
n = n + 1: ReDim Preserve TblS(1 To
Ncol, 1 To n)
For k = 1 To Ncol: TblS(k, n) = lig.Range.Item(1,
k): Next k
End If
Next lig
ReDim Preserve TblS(1 To Ncol, 1 To Application.Caller.Rows.Count)
LignesFiltrees1 = Application.Transpose(TblS)
End Function
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
Copie d'une BD sans les lignes vides
Sub copierSansVides()
ActiveSheet.Range("$A$1:$F$10000").AutoFilter Field:=1,
Criteria1:="<>", Operator:=xlAnd
Sheets.Add after:=Sheets(Sheets.Count)
Sheets("BD").Range("_FilterDataBase").SpecialCells(xlCellTypeVisible).Copy
[A1]
End Sub
Choix des items dans une ListBox
L'opérateur choisi les items dans une 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().
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
Indique si un champ est filtré par MFC
Pour appliquer une MFC sur les titres:
-Sélectionner A1:G1
-Format/mise en forme conditionnelle/La formule est
=ChampActif(A1)
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
Fonctions personnalisées
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 =FiltreCol(champColBD;TitreCol) donne l’expression du filtre pour la colonne
Function FiltreCol(Champ As Range, TitreChamp As Range)
Application.Volatile
If Not ChampActif(TitreChamp) Then FiltreCol = "":
Exit Function
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
For Each c In Champ
If Not c.EntireRow.Hidden And c.Value <>
"" Then d(c.Value) = c.Value
Next c
a = d.items
If IsDate(Champ(1)) Then
If d.Count = 1 Then
FiltreCol = TitreChamp &
":" & Format(a(0), "dd/mm/yyyy")
Else
mini = a(0): maxi = a(0)
For i = LBound(a) To UBound(a)
If a(i) < mini
Then mini = a(i)
If a(i) > maxi
Then maxi = a(i)
Next i
FiltreCol = TitreChamp &
":" & "> " & mini & " et <
" & maxi
End If
Else
FiltreCol = TitreChamp & ":"
& Join(a, ",")
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.
Sélection inversée
Sur cet exemple, l'opérateur peut inverser les choix de villes qu'il a fait
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 10000 éléments
Les listes déroulantes du filtre auto n'affichent
que les 10000 premières lignes.
Le Menu crée avec la BO boîte à outils contrôles
permet d'afficher + de 10000 lignes
Filtre
Auto Sup 10000
Filtre Auto
Sup 10000 Intuitif
Filtre Auto Sup 1000_2
Private Sub ComboBox1_GotFocus()
Set d = CreateObject("Scripting.Dictionary")
For Each c In Range([A4], [A65000].End(xlUp))
If Not d.Exists(c.Value) Then d(c.Value)
= ""
Next c
temp = d.keys
tri temp, LBound(temp), UBound(temp)
Me.ComboBox1.List = temp
End Sub
Private Sub ComboBox1_Change()
[A3].AutoFilter field:=1, Criteria1:=ComboBox1
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
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
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
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.
Pilotage
filtre automatique avec 1 à 6 ComboBoxs
Pilotage filtre
automatique avec 1 à 10 ComboBoxs
Pilotage
filtre automatique sans formulaire avec 1 à 4 ComboBoxs
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
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
Filtre clône
En modifiant le filtre d'une feuille, le filtre d'une autre feuille est modifié avec les mêmes critères.
Sub FiltreMagasins()
filtreVille = FiltreCol(Sheets(1).[B2:B1000], Sheets(1).[B1])
Tbl = Split(filtreVille, ",")
Sheets(2).ListObjects("OtreTablo").Range.AutoFilter
Field:=2, Criteria1:=Tbl, Operator:=xlFilterValues
'--
filtreQuartier = FiltreCol(Sheets(1).[c2:c1000], Sheets(1).[c1])
Tbl = Split(filtreQuartier, ",")
Sheets(2).ListObjects("OtreTablo").Range.AutoFilter
Field:=3, Criteria1:=Tbl, Operator:=xlFilterValues
'---
filtreMagasin = FiltreCol(Sheets(1).[d2:d1000], Sheets(1).[d1])
Tbl = Split(filtreMagasin, ",")
Sheets(2).ListObjects("OtreTablo").Range.AutoFilter
Field:=4, Criteria1:=Tbl, Operator:=xlFilterValues
Calculate
End Sub