XL 2016 VBA - Est-il possible de récupérer toutes les valeurs de filtre possible sans parcourir la colonne

[Dudu2]

Bonjour,

Supposons un colonne qui peut être filtrée et qui est ou non filtrée.
Peut-on récupérer toutes les valeurs listées dans la liste déroulante du filtre sans parcourir les données.

Soit ce tableau:

Je voudrais récupérer ça:

ou

 

[sylvanu]

Bonjour Dudu,
Peut être un début de piste.
L' IA Gemini m'a donnée cette solution.
Elle semble marcher mais présente un défaut, si le nombre d'éléments filtrés est 2 alors il ne remonte que le premier.
Ensuite ça marche correctement il remonte bien la liste de tous les éléments filtrés.
Mais je n'ai pas trouvé où se situait le souci. 🙁

 

[wDog66]

Bonjour à vous,
Sans parcourir les données, ce n'est pas possible, mais c'est très rapide 😜
Sans avoir ouvert le fichier de sylvanu, voici ce que je propose

Sub ListeValeursUniquesColonneFiltree()
    Dim ws As Worksheet
    Dim lo As ListObject
    Dim colFiltre As Long, i As Long
    Dim rngData As Range, cel As Range
    Dim dict As Object
    Dim result As String
    Dim val As Variant
    
    Set ws = ActiveSheet
    Set lo = ws.ListObjects(1) ' ou "Ts_TRUC" si ton tableau s'appelle Tx_TRUC
    ' Vérifier si filtre actif
    If lo.AutoFilter Is Nothing Then
        MsgBox "Aucun filtre actif dans le tableau.", vbInformation
        Exit Sub
    End If
    ' Trouver la première colonne filtrée
    colFiltre = 0
    For i = 1 To lo.ListColumns.Count
        If lo.AutoFilter.Filters(i).On Then
            colFiltre = i
            Exit For
        End If
    Next i
    If colFiltre = 0 Then
        MsgBox "Aucune colonne filtrée.", vbInformation
        Exit Sub
    End If
    ' Définir la plage de données à récupérer
    Set rngData = lo.ListColumns(colFiltre).DataBodyRange
    ' Dictionnaire pour supprimer doublons
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    ' Parcourir les cellules de la plage
    For Each cel In rngData.Cells
        val = cel.Value
        If Len(val & "") > 0 Then
            If Not dict.Exists(val) Then dict.Add val, val
        End If
    Next cel
    ' Résultat
    For Each val In dict.Items
        result = result & val & vbCrLf
    Next val
    MsgBox "Toutes les valeurs uniques de la colonne " & _
           lo.ListColumns(colFiltre).Name & " :" & vbCrLf & vbCrLf & result
End Sub

A+

 

[sylvanu]

Re,
Et l'IA est capable de se corriger. 🙂
En PJ la correction.

 

[sylvanu]

@wDog66,
bonjour. Après test votre macro ne donne pas la liste des éléments filtrés mais la liste des éléments uniques.
Or si je comprend bien Dudu, il veut la liste que des éléments filtrés.

 

[Dudu2]

Bonjour @sylvanu, @wDog66 ,
Merci de vous intéresser à ce sujet.

@wDog66, le fichier de 350.000 lignes et 137 colonnes que j'ai à traiter n'est pas très propice au parcours des valeurs.
C'est ce que je fais actuellement mais je charge chaque colonne en table pour aller plus vite.

@sylvanu, merci ça fonctionne mais c'est aussi basé sur un parcours des valeurs.

 

[Dudu2]

Pour avoir les critères de filtre d'un colonne, j'ai fait cette fonction. Mais ça ne retourne que les critères de filtre.
Hélas si la colonne n'est pas filtrée , ça ne retourne rien.

'--------------------------------------------------------
'Critères de filtres d'une colonne d'un Tableau Structuré
'Return: False si aucun filtre sur colonne
'        Tableau des valeurs des critères de filtre
'--------------------------------------------------------
Public Function TabCriteria1FiltresColonneTS(Tbl As ListObject, TblNoColonne As Integer) As Variant
    Dim TabCritères()
    Dim Criteria1 As Variant
    Dim Criteria2 As Variant
    Dim Operator As Variant
    Dim ErrNumber As Long
    Dim i As Integer

    'Init Return Value
    TabCriteria1FiltresColonneTS = False
 
    'Contrôle sur numéro de colonne
    If Not (TblNoColonne >= 1 And TblNoColonne <= Tbl.ListColumns.Count) Then Exit Function
 
    'La colonne n'est pas filtrée
    If Not ColonnesFiltréesTS(Tbl) Then Exit Function

    With Tbl
        With .AutoFilter
            On Error Resume Next
            Criteria1 = .Filters(TblNoColonne).Criteria1
            ErrNumber = Err.Number
            On Error GoTo 0

            'Pas de Critéria1
            If Not ErrNumber = 0 Then Exit Function
         
            'Criteria1 = tableau de valeurs
            If IsArray(Criteria1) Then
                ReDim TabCritères(1 To UBound(Criteria1))
                For i = LBound(Criteria1) To UBound(Criteria1)
                    TabCritères(i) = Mid(CStr(Criteria1(i)), 2)
                Next i
         
            'Critéria1 = une seule valeur
            Else
                On Error Resume Next
                'Critéria2 = une valeur
                Criteria2 = .Filters(TblNoColonne).Criteria2
                Operator = .Filters(TblNoColonne).Operator
                ErrNumber = Err.Number
                On Error Resume Next
             
                If Err.Number = 0 And Operator = xlOr Then
                    ReDim TabCritères(1 To 2)
                    TabCritères(1) = Mid(CStr(Criteria1), 2)
                    TabCritères(2) = Mid(CStr(Criteria2), 2)
                Else
                    ReDim TabCritères(1 To 1)
                    TabCritères(1) = Mid(CStr(Criteria1), 2)
                End If
            End If
        End With
    End With
 
    'Return Value
    TabCriteria1FiltresColonneTS = TabCritères
End Function

 

[sylvanu]

mais c'est aussi basé sur un parcours des valeurs.

Oups, la V2 c'est vrai je n'ai pas remarqué.
Par contre la V1 n'a pas de boucles et est très rapide.
En PJ sur 100k lignes cela donne <4ms pour Gemini et 0.6s pour une boucle.
Mais le souci est lorsqu'on a que 2 critères, il n'en renvoie qu'un. J'ai isolé le souci mais n'arrive pas à le résoudre.
Pour plus de 2 critères la liste est renvoyée dans un array ( nommé Criteria1 )

Quand il n'y a que 2 critères, on n'a plus d'array mais seulement deux valeurs :

Je vais essayer de tricher pour voir si on peut s'en sortir.

 

[sylvanu]

Hélas si la colonne n'est pas filtrée , ça ne retourne rien.

Oups, la mienne aussi. 🙁

Malheureusement, cela semble inévitable. Gemini dit :

Malheureusement, en VBA Excel, lorsque l'option de filtrage est "Tout sélectionner", la liste des critères de filtrage individuels n'est pas directement accessible.
Le filtre automatique (AutoFilter) est conçu pour stocker les critères de filtrage uniquement lorsque le filtre est actif et que des éléments sont désélectionnés. Quand l'option "Tout sélectionner" est cochée, le filtre est considéré comme désactivé et aucune information sur les valeurs possibles n'est conservée.

 

[Dudu2]

@sylvanu, il faut que ça rendre la liste des valeurs qu'il y ait un filtre placé ou pas.
Il ne s'agit pas de rendre la liste des valeurs d'un filtre placé. Pour ça la fonction du Post #7 le fait.
A mon avis c'est impossible, mais on ne sait jamais.

Ou alors, défiltrer la colonne, ajouter une valeur barbare, filtrer sur tout sauf celle valeur, récupérer les valeurs de filtre, restorer les filtre d'origine !

 

[Bernard_XLD]

Bonjour le fil le forum

A mon avis c'est impossible, mais on ne sait jamais.

@Dudu2 , en passant par un segment qui contient la liste exhaustive des éléments filtrables.
voir pièce jointe

Cordialement,
Bernard_XLD

[édition, j'ai essayé avec 400000 lignes et 160 colonnes, quasi instantané chez moi, 16 centièmes de seconde]

Sub Test_Segment()
Dim Slicer_Item As slicerItem, Objet_Segment As Object, Chaine_temp$
Set Objet_Segment = ActiveWorkbook.SlicerCaches.Add2(ActiveSheet.ListObjects("Tableau1"), "Col1").Slicers.Add(ActiveSheet, , "Col1", "Col1", 318, 879.75, 144, 210)
For Each Slicer_Item In ActiveWorkbook.SlicerCaches("Segment_Col1").SlicerItems
    Chaine_temp = IIf(Chaine_temp = vbNullString, Slicer_Item.Name, Chaine_temp & "_" & Slicer_Item.Name)
Next Slicer_Item
Chaine_temp = ActiveWorkbook.SlicerCaches("Segment_Col1").SlicerItems.Count & " items en colonne 1 :" & vbLf & Chaine_temp
Objet_Segment.Delete
MsgBox Chaine_temp, vbOKOnly + vbInformation
End Sub

 

[laurent950]

Bonsoir le Forum

Partie 1 : test

******************************************************************************************************************************************

Le code ci-dessous ne répond pas à la demande du poste #1 mais il sert de base pour la compréhension.

Le Module Standard lui est associer au module de classe clsFiltre... de ce poste #12

Bien sûr plus bas en poste #13 (On conserve le module de classe clsFiltre) mais on modifie le module standard

c'est ici tous l'interet de passé par un module de classe.

' ***********************************************************************************************************************

voici le code Module standard + Module de classe si dessous (Partie compréhension)
en passant via un module de classe : clsFiltre

Module standard :

Option Explicit
Sub CaptureFiltresAvecClasse_SimpleFiltre()
    Dim ws As Worksheet
    Dim af As AutoFilter
    Dim f As Filter
    Dim colFiltres As New Collection
    Dim oFiltre As clsFiltre
    Dim crit As Variant
    Dim i As Long
 
    Set ws = ActiveSheet
    Set af = ws.AutoFilter
 
    If af Is Nothing Then
        MsgBox "Aucun filtre actif sur cette feuille."
        Exit Sub
    End If
 
    ' Parcourir les filtres appliqués
    For i = 1 To af.Range.Columns.Count
        Set f = af.Filters(i)
        If f.On Then
            Set oFiltre = New clsFiltre
            oFiltre.NomColonne = af.Range.Rows(1).Cells(1, i).Value
       
            ' Récupérer les critères
            If IsArray(f.Criteria1) Then
                For Each crit In f.Criteria1
                    oFiltre.AddValeur crit
                Next crit
            Else
                oFiltre.AddValeur f.Criteria1
                If f.Operator > 0 Then
                    oFiltre.AddValeur f.Criteria2
                End If
            End If
       
            colFiltres.Add oFiltre, oFiltre.NomColonne
        End If
    Next i
 
    ' === Exemple d’affichage ===
    Dim j As Long
    For i = 1 To colFiltres.Count
        Debug.Print "Colonne filtrée : " & colFiltres(i).NomColonne
        For j = 1 To colFiltres(i).Valeurs.Count
            Debug.Print "   - " & colFiltres(i).Valeurs(j)
        Next j
    Next i
End Sub

le module de classe : clsFiltre

Option Explicit

Private pNomColonne As String
Private pValeurs As Collection

' Initialisation
Private Sub Class_Initialize()
    Set pValeurs = New Collection
End Sub

' Nom de la colonne
Public Property Let NomColonne(ByVal s As String)
    pNomColonne = s
End Property
Public Property Get NomColonne() As String
    NomColonne = pNomColonne
End Property

' Accès à la collection des valeurs
Public Property Get Valeurs() As Collection
    Set Valeurs = pValeurs
End Property

' Ajouter une valeur cochée
Public Sub AddValeur(ByVal s As String)
    pValeurs.Add s
End Sub

 

[laurent950]

Bonsoir Le Forum

J'ai ajouté un fichier test : ExtractChampFiltreActifInactif_v1.xlsm

**********************************************************************************************************************************

******************************************************************************************************

voici le code Module standard + Module de classe si dessous (Partie Solution)
en passant via un module de classe : clsFiltre

Partie 2 : Solution

Pour avoir les critères de filtre d'un colonne, j'ai fait cette fonction. Mais ça ne retourne que les critères de filtre.
Hélas si la colonne n'est pas filtrée , ça ne retourne rien.

Avec la puissance du le module de classe : clsFiltre , on adapte le module standard a sa guise.

Le module standard ci-dessous : Bien sur celui-ci est associé au module de classe : clsFiltre en Poste #12

Sub CaptureFiltresEtCopieFeuille()
    Dim ws As Worksheet, wsResult As Worksheet
    Dim af As AutoFilter
    Dim colFiltres As New Collection
    Dim oFiltre As clsFiltre
    Dim f As Filter
    Dim crit As Variant
    Dim i As Long, j As Long
    Dim lastRow As Long
    Dim cell As Range
    Dim dict As Object
    Dim estFiltre As Boolean
    Dim ligne As Long
 
    Set ws = ActiveSheet
    Set af = ws.AutoFilter
 
    ' Créer ou nettoyer la feuille de résultat
    On Error Resume Next
    Set wsResult = ThisWorkbook.Sheets("FiltreSansParcourirColonne")
    If wsResult Is Nothing Then
        Set wsResult = ThisWorkbook.Sheets.Add
        wsResult.Name = "FiltreSansParcourirColonne"
    Else
        wsResult.Cells.Clear
    End If
    On Error GoTo 0
 
    ligne = 1
 
    ' Boucle sur toutes les colonnes de la plage utilisée
    For i = 1 To ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set oFiltre = New clsFiltre
        oFiltre.NomColonne = ws.Cells(1, i).Value
        Set dict = CreateObject("Scripting.Dictionary")
        estFiltre = False
    
        ' Vérifier si un filtre existe et est actif sur cette colonne
        If Not af Is Nothing Then
            Set f = af.Filters(i)
            If f.On Then
                estFiltre = True
                ' Valeurs sélectionnées uniquement
                If IsArray(f.Criteria1) Then
                    For Each crit In f.Criteria1
                        oFiltre.AddValeur crit
                    Next crit
                Else
                    oFiltre.AddValeur f.Criteria1
                    If f.Operator > 0 Then
                        oFiltre.AddValeur f.Criteria2
                    End If
                End If
            End If
        End If
    
        ' Si la colonne n'est pas filtrée, on ajoute toutes les valeurs uniques
        If Not estFiltre Then
            lastRow = ws.Cells(ws.Rows.Count, i).End(xlUp).Row
            For Each cell In ws.Range(ws.Cells(2, i), ws.Cells(lastRow, i))
                If Not dict.exists(cell.Value) Then
                    oFiltre.AddValeur cell.Value
                    dict(cell.Value) = True
                End If
            Next cell
        End If
    
        ' Ajouter l'objet filtre à la collection principale
        colFiltres.Add oFiltre, oFiltre.NomColonne
    
        ' === Affichage dans la feuille ===
        If estFiltre Then
            wsResult.Cells(ligne, 1).Value = "Colonne (Filtré) : " & oFiltre.NomColonne
        Else
            wsResult.Cells(ligne, 1).Value = "Colonne (Non Filtré) : " & oFiltre.NomColonne
        End If
        ligne = ligne + 1
    
        For j = 1 To oFiltre.Valeurs.Count
            wsResult.Cells(ligne, 1).Value = "   - " & oFiltre.Valeurs(j)
            ligne = ligne + 1
        Next j
    
        wsResult.Cells(ligne, 1).Value = String(40, "*") ' Séparateur
        ligne = ligne + 1
    Next i
 
    wsResult.Columns(1).AutoFit
    MsgBox "Résultat copié sur la feuille 'FiltreSansParcourirColonne'.", vbInformation
End Sub

 

[Dudu2]

Merci @Bernard_XLD, @laurent950 pour vos retours.

Pour l'instant je n'ai testé que la solution de @Bernard_XLD qui fait appel à des notions (Segment, slicerItem) qui me sont totalement étrangères ! Et ça marche ! Suis impressionné.

Je vais regarder le code de @laurent950 qui me semble également au-delà de mes connaissances.

 

[laurent950]

Je vais regarder le code de @laurent950 qui me semble également au-delà de mes connaissances.

Vous n’avez pas pu intégrer le code dans votre fichier ? Il y a deux modules à ajouter.
Si vous avez un exemple de fichier, je peux compiler le code et l’exemple pour que ce soit plus parlant.

@Dudu2 J'ai ajouter un fichier test en Poste #12 et Poste #13