none
VBA - Récupérer les valeurs des filtres automatiques dans Excel RRS feed

  • Question

  • Bonjour à tous,

    J'ai une feuille Excel qui contient des filtres automatiques.

    Disons que ces filtres trient les données sur la colonne A en Ascendant et que les données sont filtrées sur les 2 premières valeurs de la colonne B (c'est un exemple.)

    Comment, via VBA, puis-je retrouver ces informations ?

     

    Merci à vous.

    Alexandre

     

    mardi 17 mai 2011 21:55

Réponses

  • Bonsoir,

     

    Voila un code qui fait ce que je souhaite : il est très commenté et explicite pour plus de clarté, on peut le simplifier.

    Il reprend le code d'isabelleV :

     

    Sub GetFilters()
    
      Dim Wsht As Worksheet
      
      ' Variables Filtre
      Dim FilterArr() As Variant
      Dim ColNum As Long, Crit1Num As Long, NbFiltCol As Long
      
      ' Variables Tri
      Dim SrtColKey As Long, SrtOn As XlSortOn, SrtOrder As XlSortOrder
      Dim SrtDataOption As XlSortDataOption, SrtHeader As XlYesNoGuess, SrtMatchCase As Boolean
      Dim SrtOrientation As XlSortOrientation, SrtMethod As XlSortMethod, FiledsNum As Long
      
      Dim SortGenricValArr(3) As Variant, SortFiledsValArr(4) As Variant
    
      Set Wsht = Worksheets(1)
      With Wsht
    
        ' Test Tris
        If .AutoFilter.Sort.SortFields.Count > 0 Then
          With .AutoFilter.Sort
            
            SrtHeader = .Header
            SortGenricValArr(0) = SrtHeader
            
            SrtMatchCase = .MatchCase
            SortGenricValArr(1) = SrtMatchCase
            
            SrtOrientation = .Orientation
            SortGenricValArr(2) = SrtOrientation
            
            SrtMethod = .SortMethod
            SortGenricValArr(3) = SrtMethod
            
            For FiledsNum = 1 To .SortFields.Count
              SortFiledsValArr(0) = FiledsNum
              
              With .SortFields(FiledsNum)
                SrtColKey = .Key.Column
                SortFiledsValArr(1) = SrtColKey
                
                SrtOn = .SortOn
                SortFiledsValArr(2) = SrtOn
                
                SrtOrder = .Order
                SortFiledsValArr(3) = SrtOrder
                
                SrtDataOption = .DataOption
                SortFiledsValArr(4) = SrtDataOption
                
              End With
            Next FiledsNum
          End With
        End If
        
        ' Test Filtres
        With .AutoFilter.Filters
    
          ' Décompte à l'avance Nombre de Colonnes Dont Filtre Actif
          ' Car Première Dim d'un Array Multi Non Dynamique
          For ColNum = 1 To .Count
            
            ' Si Filtre Actif
            If .Item(ColNum).On Then
              NbFiltCol = NbFiltCol + 1
            End If
          Next ColNum
          ReDim FilterArr(NbFiltCol - 1, 1)
          
          ' Boucle sur les Colonnes
          Dim Cpt As Long
          For ColNum = 1 To .Count
            With .Item(ColNum)
              
              ' Si Filtre Actif
              If .On Then
                FilterArr(Cpt, 0) = ColNum
                FilterArr(Cpt, 1) = .Operator
                
                ' Boucle sur les Valeurs Du Filtre
                For Crit1Num = 1 To .Count
                
                  ' Redimensionnement Dynamique 2ème Dim de l'Array
                  ReDim Preserve FilterArr(Cpt, UBound(FilterArr, 2) + 1)
                  FilterArr(Cpt, UBound(FilterArr, 2)) = .Criteria1(Crit1Num)
                Next Crit1Num
                Cpt = Cpt + 1
              End If
            End With
          Next
        End With
      End With
    End Sub
    

     

    Merci à tous et toutes.

    Alexandre

    • Marqué comme réponse avaesken vendredi 20 mai 2011 19:20
    vendredi 20 mai 2011 19:20

Toutes les réponses

  • Bonjour,

    Le forum actuel est celui pour VB.Net

    il y a un forum pour VBA ici

    http://social.msdn.microsoft.com/Forums/fr-FR/vbafr/threads/

     


    fred
    mercredi 18 mai 2011 17:52
  • Bonjour,

    Pense que c'est pour rejoindre cette conversation ?

    http://social.msdn.microsoft.com/Forums/fr-FR/vbasicfr/thread/6e0e565d-2999-44e9-99a7-0c8e3fdeba1e
    (un modérateur fera un move du thread)

     

    A bientot


    Cordialement,
    Xavier TALOUR
    Alias Troxsa SendMail Voir le profil de Xavier TALOUR sur LinkedIn
    mercredi 18 mai 2011 18:17
  • bonjour Alexandre,
     
    [code]
    Dim w As Worksheet
    Dim filterArray()
    Dim currentFiltRange As String
     
    Sub LireFilters()
    Set w = Worksheets("Feuil1")
    With w.AutoFilter
        currentFiltRange = .Range.Address
        With .Filters
            ReDim filterArray(1 To .Count, 1 To 3)
            For f = 1 To .Count
                With .Item(f)
                    If .On Then
                        filterArray(f, 1) = .Criteria1
                        If .Operator Then
                            filterArray(f, 2) = .Operator
                            filterArray(f, 3) = .Criteria2
                        End If
                    End If
                End With
            Next
        End With
    End With
    [H26:K28] = Application.Transpose(filterArray)
    End Sub
    [/code]
     --
    isabelle
     
     
    jeudi 19 mai 2011 12:12
  • Bonjour, avaesken,

    Est-ce que vous avez testé la solution proposée ? Merci pour partager avec nous les résultats, afin que d'autres personnes avec le même problème puissent profiter de cette solution.

     

    Bonne journée,

    Cipri


    Suivez MSDN sur Twitter   Suivez MSDN sur Facebook


    Ciprian DUDUIALA, MSFT  
    •Nous vous prions de considérer que dans le cadre de ce forum on n’offre pas de support technique et aucune garantie de la part de Microsoft ne peut être offerte.

    vendredi 20 mai 2011 06:57
  • Bonjour,

     

    Le code plante sur .Criteria2, mais m'apporte de notables réponses, notamment sur la détermination des colonnes filtrées et l'énumération des critères de filtres.

    Le plantage n'est donc pas important.

    Reste, en revanche, que l'on ne voit pas si en plus des filtres, un tri est appliqué.

    Je vais chercher.

     

    Je donnerai une réponse avec la solution lorsque je l'aurais.

     

    Merci encore à IsabelleV pour ce nouveau coup de main.

    Alexandre

    vendredi 20 mai 2011 17:49
  • Bonsoir,

     

    Voila un code qui fait ce que je souhaite : il est très commenté et explicite pour plus de clarté, on peut le simplifier.

    Il reprend le code d'isabelleV :

     

    Sub GetFilters()
    
      Dim Wsht As Worksheet
      
      ' Variables Filtre
      Dim FilterArr() As Variant
      Dim ColNum As Long, Crit1Num As Long, NbFiltCol As Long
      
      ' Variables Tri
      Dim SrtColKey As Long, SrtOn As XlSortOn, SrtOrder As XlSortOrder
      Dim SrtDataOption As XlSortDataOption, SrtHeader As XlYesNoGuess, SrtMatchCase As Boolean
      Dim SrtOrientation As XlSortOrientation, SrtMethod As XlSortMethod, FiledsNum As Long
      
      Dim SortGenricValArr(3) As Variant, SortFiledsValArr(4) As Variant
    
      Set Wsht = Worksheets(1)
      With Wsht
    
        ' Test Tris
        If .AutoFilter.Sort.SortFields.Count > 0 Then
          With .AutoFilter.Sort
            
            SrtHeader = .Header
            SortGenricValArr(0) = SrtHeader
            
            SrtMatchCase = .MatchCase
            SortGenricValArr(1) = SrtMatchCase
            
            SrtOrientation = .Orientation
            SortGenricValArr(2) = SrtOrientation
            
            SrtMethod = .SortMethod
            SortGenricValArr(3) = SrtMethod
            
            For FiledsNum = 1 To .SortFields.Count
              SortFiledsValArr(0) = FiledsNum
              
              With .SortFields(FiledsNum)
                SrtColKey = .Key.Column
                SortFiledsValArr(1) = SrtColKey
                
                SrtOn = .SortOn
                SortFiledsValArr(2) = SrtOn
                
                SrtOrder = .Order
                SortFiledsValArr(3) = SrtOrder
                
                SrtDataOption = .DataOption
                SortFiledsValArr(4) = SrtDataOption
                
              End With
            Next FiledsNum
          End With
        End If
        
        ' Test Filtres
        With .AutoFilter.Filters
    
          ' Décompte à l'avance Nombre de Colonnes Dont Filtre Actif
          ' Car Première Dim d'un Array Multi Non Dynamique
          For ColNum = 1 To .Count
            
            ' Si Filtre Actif
            If .Item(ColNum).On Then
              NbFiltCol = NbFiltCol + 1
            End If
          Next ColNum
          ReDim FilterArr(NbFiltCol - 1, 1)
          
          ' Boucle sur les Colonnes
          Dim Cpt As Long
          For ColNum = 1 To .Count
            With .Item(ColNum)
              
              ' Si Filtre Actif
              If .On Then
                FilterArr(Cpt, 0) = ColNum
                FilterArr(Cpt, 1) = .Operator
                
                ' Boucle sur les Valeurs Du Filtre
                For Crit1Num = 1 To .Count
                
                  ' Redimensionnement Dynamique 2ème Dim de l'Array
                  ReDim Preserve FilterArr(Cpt, UBound(FilterArr, 2) + 1)
                  FilterArr(Cpt, UBound(FilterArr, 2)) = .Criteria1(Crit1Num)
                Next Crit1Num
                Cpt = Cpt + 1
              End If
            End With
          Next
        End With
      End With
    End Sub
    

     

    Merci à tous et toutes.

    Alexandre

    • Marqué comme réponse avaesken vendredi 20 mai 2011 19:20
    vendredi 20 mai 2011 19:20
  • bonjour Alexandre,
     
    contente de voir que tu as réussi à l'adapter et que tous va bien,
    merci pour ce retour!
     
    --
    isabelle
     
     
    vendredi 20 mai 2011 20:51
  • Bonjour,

    Et merci Isabelle et Alexandre pour vos contributions qui m'ont permis, en focalisant sur les Filtres, de créer une fonction VBA pour mes besoins et que je partage ici.

    J'ai adapté la capture des critères qui ne sont rendus en tableau que quand leur nombre est > 2.
    Et aussi ajusté le parcours des colonnes sur le Range de l'AutoFilter qui ne commence pas forcément en colonne 1 ni d'ailleurs en ligne 1. D'où les informations complémentaires retournées.

    Cordialement,
    JP

    'Flag for traces MsgBox
    Private Const FLT_Trace = False ' True
    
    '------------------------------------------------------
    'Returns a table of Active Filters Tab(1 To n, 1 To 8+)
    'within the Worksheet argument WS, where:
    '1 to n  = n Active Filters (n > 0)
    '1 to 8+ = Active Filter information
    '      1 = Column number,
    '      2 = Row number,
    '      3 = Number of rows,
    '      4 = Field (Column number in the AutoFilter.Range)
    '      5 = Number of Criteria,
    '      6 = Operator,
    '      7 = Criteria1,
    '      8 = Criteria2,
    '     8+ = +other Criteria if any
    '
    'Constants to indice the 2nd dimension of the returned
    'Table of Active Filters
    Public Const FLT_Column = 1
    Public Const FLT_Row = 2
    Public Const FLT_RowsCount = 3
    Public Const FLT_Field = 4
    Public Const FLT_CriteriaCount = 5
    Public Const FLT_Operator = 6
    Public Const FLT_Criteria0 = 6
    Public Const FLT_Criteria1 = 7
    Public Const FLT_Criteria2 = 8
    '
    'If no Active Filter, returns Null (test it IsNull() !)
    '
    'https://docs.microsoft.com/fr-fr/office/vba/api/excel.xlautofilteroperator
    '------------------------------------------------------
    
    Function FLT_ActiveFilterGet(WS As Worksheet) As Variant
        Dim AutoFilterRange As Range
        Dim TabActiveFilter() As Variant
        Dim ActiveFilterNb As Long
        Dim ColumnNb As Long
        Dim CriteriaNb As Integer
        Dim i As Integer
        Dim S As String
    
        'If Worksheet AutoFilterMode is True
        If WS.AutoFilterMode Then
            Set AutoFilterRange = WS.AutoFilter.Range
            If FLT_Trace Then MsgBox "FLT_ActiveFilterGet - AutoFilterRange = " & AutoFilterRange.Address
    
            'Search filters
            With WS.AutoFilter.Filters
                'Loop on columns with filters active or not
                ActiveFilterNb = 0
                For ColumnNb = AutoFilterRange.Column To AutoFilterRange.Column + AutoFilterRange.Columns.Count - 1
                    'If filter is active
                    If .Item(ColumnNb - AutoFilterRange.Column + 1).On Then ActiveFilterNb = ActiveFilterNb + 1
                Next ColumnNb
                If FLT_Trace Then MsgBox "ActiveFilterNb = " & ActiveFilterNb
    
                If ActiveFilterNb > 0 Then
                    'Sizes the active filters table
                    Erase TabActiveFilter
                    ReDim TabActiveFilter(1 To ActiveFilterNb, 1 To FLT_Criteria0 + 2)   'By default 2 criteria (Criteria1 & Criterai2)
    
                    'Loop on columns with filters active or not
                    ActiveFilterNb = 0
                    For ColumnNb = AutoFilterRange.Column To AutoFilterRange.Column + AutoFilterRange.Columns.Count - 1
                        With .Item(ColumnNb - AutoFilterRange.Column + 1)
                            'If filter is active
                            If .On Then
                                ActiveFilterNb = ActiveFilterNb + 1
                                TabActiveFilter(ActiveFilterNb, FLT_Column) = ColumnNb
                                TabActiveFilter(ActiveFilterNb, FLT_Row) = AutoFilterRange.Row
                                TabActiveFilter(ActiveFilterNb, FLT_RowsCount) = AutoFilterRange.Rows.Count
                                TabActiveFilter(ActiveFilterNb, FLT_Field) = ColumnNb - AutoFilterRange.Column + 1
                                TabActiveFilter(ActiveFilterNb, FLT_CriteriaCount) = .Count
                                TabActiveFilter(ActiveFilterNb, FLT_Operator) = .Operator
    
                                'Retrieve filter criteria
                                Select Case .Count
                                    Case 1
                                        TabActiveFilter(ActiveFilterNb, FLT_Criteria1) = .Criteria1
    
                                    Case 2
                                        TabActiveFilter(ActiveFilterNb, FLT_Criteria1) = .Criteria1
                                        TabActiveFilter(ActiveFilterNb, FLT_Criteria2) = .Criteria2
    
                                    Case Is > 2
                                        If FLT_Criteria0 + .Count > UBound(TabActiveFilter, 2) Then
                                            ReDim Preserve TabActiveFilter(1 To UBound(TabActiveFilter, 1), 1 To FLT_Criteria0 + .Count)
                                        End If
    
                                        For CriteriaNb = 1 To .Count
                                            TabActiveFilter(ActiveFilterNb, FLT_Criteria0 + CriteriaNb) = .Criteria1(CriteriaNb)
                                        Next CriteriaNb
                                End Select
    
                                'Trace
                                If FLT_Trace Then
                                    S = "Column = " & TabActiveFilter(ActiveFilterNb, FLT_Column) & ", " & _
                                        "Row = " & TabActiveFilter(ActiveFilterNb, FLT_Row) & ", " & _
                                        "RowsCount = " & TabActiveFilter(ActiveFilterNb, FLT_RowsCount) & ", " & _
                                        "Field = " & TabActiveFilter(ActiveFilterNb, FLT_Field) & ", " & _
                                        "Operator = " & TabActiveFilter(ActiveFilterNb, FLT_Operator) & vbCrLf & _
                                        "CriteriaCount = " & TabActiveFilter(ActiveFilterNb, FLT_CriteriaCount)
                                    For i = 1 To TabActiveFilter(ActiveFilterNb, FLT_CriteriaCount)
                                        S = S & vbCrLf & "Criteria" & i & " = """ & TabActiveFilter(ActiveFilterNb, FLT_Criteria0 + i) & """"""
                                    Next i
                                    MsgBox S
                                End If
                            End If
                        End With
                    Next
                End If
            End With
        End If
    
        If ActiveFilterNb > 0 Then
            FLT_ActiveFilterGet = TabActiveFilter
        Else
            FLT_ActiveFilterGet = Null
        End If
    
    End Function



    • Modifié Picolium vendredi 25 janvier 2019 17:11
    • Proposé comme réponse Fane007 mardi 4 juin 2019 09:38
    jeudi 24 janvier 2019 11:58
  • Bonjour Picolium et le forum, 

    Merci pour votre code qui fonctionne impeccable. Je voudrais enregistrer les filtres à la fermeture du classeur, mais je ne sais pas comment stocker le tableau afin de ré appliquer les mêmes filtres à l'ouverture de ce même classeur. Avez vous une idée qui pourrait m'aiguiller ? Merci d'avance

    Stephane

    mardi 4 juin 2019 09:38