Discussion :

[Guy_M]

Bonjour,

J'ai lu cette discussion.

Cf fonction filtretotal()
(...)

JB

Cette fonction ne fonctionne pas avec les tableaux Excel (ListObjects). Pour mon usage personnel, j'ai fait une petite adaptation pour prendre en compte ce cas là.

Limitations :
Si il y a un tableau, cela ne prend en compte que le premier tableau (ListObject) et donc si une autre zone de la feuille est filtrée, elle est ignorée.
Cette fonction a l'air de mal cohabiter avec Power Query (je dois fait "stop" dans Visual Basic pour reprendre la main dans la feuille de calcul, on peut contourner en supprimant ou en mettant en commentaire la ligne "Application.Volatile", dans ce cas la mise à jour doit être faites à la main.)

En espérant que cela sera utile à quelqu'un.

Code VBA :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
'Cette fonction permet de retourner le filtre appliqué à feuille appelante
'Origine du code http://www.developpez.net/forums/d1299032/logiciels/microsoft-office/excel/macros-vba-excel/recuperer-filtre-automatique-vba/
'Ajout des déclarations de variables GM 11/10/2016
'Capacité à travailler avec 1 ListObject
Function FiltreTotal()
Dim Feuille As String
Dim C As Long
Dim Chaine As String
Dim NbColFiltre As Long
Dim FeuilCour As Worksheet
Dim ZoneFiltree As Range
 
   Application.Volatile
   Feuille = Application.Caller.Parent.Name
   Set FeuilCour = Application.Caller.Parent
   Chaine = ""
   If FeuilCour.ListObjects.Count <> 0 Then
    NbColFiltre = FeuilCour.ListObjects(1).ListColumns.Count
    Set ZoneFiltree = FeuilCour.ListObjects(1).AutoFilter.Range
   Else
    NbColFiltre = Sheets(Feuille).Range("_FilterDataBase").Columns.Count
    Set ZoneFiltree = Sheets(Feuille).Range("_FilterDataBase")
   End If
   For C = 1 To NbColFiltre
     If FiltreActuelNo(C) <> "" Then
       If IsDate(ZoneFiltree.Cells(2, C)) Then
         Chaine = Chaine & ZoneFiltree.Cells(1, C) & FiltreActuelNo(C, "D") & " "
       Else
         Chaine = Chaine & ZoneFiltree.Cells(1, C).value & FiltreActuelNo(C) & " "
       End If
     End If
   Next C
   If Chaine = "" Then Chaine = "Tout"
   FiltreTotal = Chaine
End Function
 
'Cette fonction permet de retourner le filtre appliqué à la colonne numéro col de la feuille appelante
'Origine du code http://www.developpez.net/forums/d1299032/logiciels/microsoft-office/excel/macros-vba-excel/recuperer-filtre-automatique-vba/
'Ajout des déclarations de variables GM 11/10/2016
'Capacité à travailler avec 1 ListObject
Function FiltreActuelNo(col As Long, Optional typeCol As String)
Dim Feuille As String
Dim temp As Variant, temp2 As Variant
Dim o As String, n As String, oper As String
Dim FeuilCour As Worksheet
Dim FiltreCour As AutoFilter
 
 Application.Volatile
 Feuille = Application.Caller.Parent.Name
 Set FeuilCour = Application.Caller.Parent
 Set FiltreCour = Nothing
 If FeuilCour.ListObjects.Count <> 0 Then
    Set FiltreCour = FeuilCour.ListObjects(1).AutoFilter
 ElseIf Sheets(Feuille).FilterMode Then
    Set FiltreCour = Sheets(Feuille).AutoFilter
 End If
 If Not FiltreCour Is Nothing Then
    If FiltreCour.Filters.Item(col).On Then
      temp = FiltreCour.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 FiltreCour.Filters.Item(col).Operator Then
          oper = IIf(FiltreCour.Filters.Item(col).Operator = 1, " ET ", " OU ")
          On Error Resume Next
          Err = 0
          temp2 = FiltreCour.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

A bientôt
Guy Marty

[joe.levrai]

Bonjour,

il est possible de récupérer les valeurs des filtres d'une feuille, y compris s'il y a plus de 2 critères.

La méthode, c'est de vérifier si Criteria1 est un Array .... et de le convertir en String (via la méthode Join)
Si ce n'est pas un Array, alors là on ira vérifier la présence éventuelle d'un Criteria2

Voici un exemple, à noter que par commodité, je supprime toujours le signe "=" quand ils sont dans les criteria ... histoire de ne pas injecter une fausse formule dans ma feuille de résultat

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Option Base 1
 
 
Sub ValeurFiltres()
Dim TableauFiltres
Dim i As Long, j As Long, Indice As Long
 Dim FEUILLE As Worksheet
 Set FEUILLE = ActiveSheet
With FEUILLE.AutoFilter.Filters
 
    ' titres du tableau de résultat
    ReDim TableauFiltres(1 To 3, 1 To 1)
    TableauFiltres(1, 1) = "CRITERE 1"
    TableauFiltres(2, 1) = "OPERATEUR"
    TableauFiltres(3, 1) = "CRITERE 2"
 
    ' pour chaque colonne
    For j = 1 To .Count
        ' le filtre de la colonne
        With .Item(j)
            ' s'il est actif
            If .On Then
                ' ajout d'une place dans le tableau
                Indice = UBound(TableauFiltres, 2) + 1
                ReDim Preserve TableauFiltres(UBound(TableauFiltres, 1), Indice)
 
                ' on récupère le Critère 1
                TableauFiltres(1, Indice) = .Criteria1
 
                ' si le critère 1 est un tableau (= le filtre est basé sur au moins 3 critères
                If IsArray(TableauFiltres(1, Indice)) Then
                    ' on converti le tableau des valeurs en une chaine de caractère
                    ' et on supprime les "="
                    TableauFiltres(1, Indice) = Replace(Join(TableauFiltres(1, Indice), ";"), "=", "")
 
                ' si le critère 1 est un string
                ' il y a possiblement un Critère 2 et un opérateur d'association
                Else
 
                    ' on enlève le "=" du critère 1
                    TableauFiltres(1, Indice) = Replace(.Criteria1, "=", "")
 
                    ' s'il y a un critère 2
                    If .Operator Then
                        ' on intègre l'opérateur et le critère 2 à la ligne du tableau
                        TableauFiltres(2, Indice) = .Operator
                        TableauFiltres(3, Indice) = Replace(.Criteria2, "=", "")
                    End If
                End If
            End If
        End With
    Next
End With
 
' on écrit dans une nouvelle feuille le résultat
With ThisWorkbook.Worksheets.Add
    .Cells(1, 1).Resize(Indice, UBound(TableauFiltres, 1)).Value = Application.Transpose(TableauFiltres)
End With
 
End Sub

EDIT : navré d'avoir lu en diagonal cet ancien sujet .... et d'avoir du coup mal interprété la problématique qui n'était pas résolue
tant pis, je laisse mon code qui pourra éventuellement servir à d'autres