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

Dudu2 · Dimanche à 14:41

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

patricktoulon · Hier à 19:20

oui @nullosse a raison la fonction native unique fait le job
a voir avec evaluate je ne sais pas
bon avec worksheetfunction ca marche donc 👍
perso je l'ai pas office 2013

mais le retour de laurent n'est pas dépourvu de sens
punaise!! il est devenu bon le petit Laurent 🤣 🤣 👍

laurent950 · Hier à 20:58

patricktoulon à dit:
a voir avec evaluate je ne sais pas

VB:

    ' --- Charger dans un tableau 2D ---
    arr = colRange.Value
    
    ' --- Convertir directement en tableau 1D avec Evaluate + Transpose ---
    arr = Application.Transpose(Evaluate(colRange.Address))

Principe

    ici comme on connait la colonne avec evaluate
    arr = Application.Transpose(Evaluate("ROW(" & LBound(arr, 2) & ":" & UBound(arr, 2) & ")")) ' = La colonne (2) soit colonne B

Code:

Sub ListeFiltreFiable_Tableau()
    Dim ws As Worksheet
    Dim colLetter As String
    Dim colNum As Long
    Dim colRange As Range
    Dim arr As Variant
   
    ' --- Initialisation ---
    Set ws = ActiveSheet
   
    ' --- InputBox pour la colonne ---
    colLetter = InputBox("Indiquez la lettre de la colonne à traiter :", "Choix de colonne", "A")
    If colLetter = "" Then Exit Sub
    colLetter = UCase(colLetter)
    colNum = Columns(colLetter).Column
   
    ' --- Définir la plage visible ---
    On Error Resume Next
    Set colRange = ws.Range(ws.Cells(2, colNum), ws.Cells(ws.Rows.Count, colNum).End(xlUp)) _
                   .SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
   
    If colRange Is Nothing Then
        MsgBox "Pas de cellules visibles dans cette colonne.", vbExclamation
        Exit Sub
    End If
   
    ' --- Charger dans un tableau 2D ---
    arr = colRange.Value
   
    ' --- Convertir directement en tableau 1D avec Evaluate + Transpose ---
    arr = Application.Transpose(Evaluate(colRange.Address))
   
    ' À ce stade, arr est un tableau 1D (1 To n) prêt pour tri ou autres traitements
    MsgBox "Colonne stockée dans un tableau 1D avec " & UBound(arr) & " valeurs."
End Sub

patricktoulon · Hier à 21:21

re oui mais arr est un array contenant les doublons aussi
il faudrait vérifier si unique prend toute la plage ou seulement les visibles
je l'avais la formule evaluate sans doublons avec rept et equiv etc... mais elle est perdues dans mes archives

si je devais faire le bilan

segment marche mais a une limite dans le nombre (au dela de 50 000 lignes risque de dépassement de capacité)et long si pas de filtre
filter criterial(methode @Dudu2) ( ça marche peut être, j'ai pas testé mais c'est une usine a gaz )
clipboard (suggéré par @nullosse) pas mal mais faut bidouiller pour les vides (voir les limite du string)
la boucle dico (patricktoulon) simple rapide mais demande des détours si on veut que les filtre actifs mais reste competitif
l'evaluate ou worksheetfunction sur unique voir si ça fonctionne sur une plage filtrée

en conclusion la décision est simple à prendre je crois non ?

patricktoulon · Hier à 21:47

re

VB:

Sub b()
    Dim TabValeursUniques
    
    TabValeursUniques = TabVDicoUniquesColonneTS(ActiveSheet.ListObjects(1), 1, True) 'rien que les filtrés
    MsgBox "Filtré : " & vbCrLf & Join(TabValeursUniques, "|")
    
    TabValeursUniques = TabVDicoUniquesColonneTS(ActiveSheet.ListObjects(1), 1)
    MsgBox "sans les Filtre : " & vbCrLf & Join(TabValeursUniques, "|")
    
End Sub

Function TabVDicoUniquesColonneTS(TS As ListObject, index, Optional filter As Boolean = False)
    Dim dic As Object, RnG As Range
    Set dico = CreateObject("Scripting.Dictionary")
    If filter Then
        Set RnG = TS.DataBodyRange.Columns(index).SpecialCells(xlCellTypeVisible)
    Else
        Set RnG = TS.DataBodyRange.Columns(index)
    End If
    With RnG
        If filter Then
            For Each area In .Areas
                For Each Cel In area.Cells
                    dico(Cel.Value) = ""
                Next
            Next
        Else
            Dim T, I&
            T = RnG.Value
            For I = 1 To UBound(T): dico(T(I, 1)) = "": Next
        End If
    End With
    TabVDicoUniquesColonneTS = dico.Keys
End Function

j'ai déjà séparé le listing complet de celui avec le filtre pour accélerer le list complet
mais si arrivez à encore plus l'accélérer ?
peut être justement remplacer dans le else le listing par l'evaluation ou worksheetfunction sur unique
pour voir si le test sur 150 000 lignes(testées chez moi) ca accélère un peu

nullosse · Aujourd'hui à 03:20

patricktoulon à dit:
mais si arrivez à encore plus l'accélérer ?
peut être justement remplacer dans le else le listing par l'evaluation ou worksheetfunction sur unique
pour voir si le test sur 150 000 lignes(testées chez moi) ca accélère un peu

Salut,
j'ai testé le code de patricktoulon et le unique sur un tableau de 250000 chaînes aléatoires de 8 caractères qu'avec 2 doublons.
voici les codes de test :

VB:

Sub b()
    Dim TabValeursUniques, bm As New cBenchmark
    bm.Start
    TabValeursUniques = TabVDicoUniquesColonneTS(Worksheets("Data").ListObjects(1), 1)
    bm.TrackByName "TabVDicoUniquesColonneTS"
    Debug.Print "nb Valeurs uniques : " & CStr(UBound(TabValeursUniques) - LBound(TabValeursUniques) + 1)
End Sub

Sub c()
    Dim TabValeursUniques, bm As New cBenchmark
    bm.Start
    TabValeursUniques = Transpose2D(WorksheetFunction.Unique( _
                        Worksheets("Data").ListObjects(1).DataBodyRange.columns(1)), _
                        LikeExcel:=True)
    bm.TrackByName "WorksheetFunction.Unique"
    Debug.Print "nb Valeurs uniques : " & CStr(UBound(TabValeursUniques) - LBound(TabValeursUniques) + 1)
End Sub

Les résultats sur mon Ordinateur en Excel 2021 : 3,74 s pour le test b et 1,73 s pour le test c

A noter que pour le test c , j'ai été obligé d'utiliser un Transpose spécial (Transpose2D ressource de Dudu2 qui se trouve ici) car le Application.Transpose à une limite d'environ 64000 éléments.

Nullosse.

patricktoulon · Aujourd'hui à 13:18

Bonjour @nullosse tu testera et tu me diras

VB:

Sub b()
    Dim TabValeursUniques
 
    TabValeursUniques = TabVDicoUniquesColonneTS(ActiveSheet.ListObjects(1), 1, True) 'rien que les filtrés
    MsgBox "Filtré : " & vbCrLf & Join(TabValeursUniques, "|")
 
    TabValeursUniques = TabVDicoUniquesColonneTS(ActiveSheet.ListObjects(1), 1)
    MsgBox "sans les Filtre : " & vbCrLf & Join(TabValeursUniques, "|")
 
End Sub

Function TabVDicoUniquesColonneTS(TS As ListObject, index, Optional filter As Boolean = False)
    Dim dic As Object, RnG As Range
    Set dico = CreateObject("Scripting.Dictionary")
    If filter Then
        Set RnG = TS.DataBodyRange.Columns(index).SpecialCells(xlCellTypeVisible)
    Else
        Set RnG = TS.DataBodyRange.Columns(index)
    End If
    With RnG
        If filter Then
            For Each area In .Areas
                For Each Cel In area.Cells
                    dico(Cel.Value) = ""
                Next
            Next
            TabVDicoUniquesColonneTS = dico.keys
        Else
            If Val(Application.Version) < 16 Then
                Dim T, I&
                T = RnG.Value
                For I = 1 To UBound(T): dico(T(I, 1)) = "": Next
                TabVDicoUniquesColonneTS = dico.keys
            Else
                T = WorksheetFunction.Unique(RnG)
                ReDim t2(1 To UBound(T))
                For I = 1 To UBound(T): t2(I) = T(I, 1): Next
                TabVDicoUniquesColonneTS = t2
            End If
        End If
    End With
End Function

on bascule sur le mode entier ou filter
et dans le mode entier on bascule sur le dico pour excel<2016 et fonction unique pour excel >2016
la partie unique je ne peut pas la tester moi

nullosse · Aujourd'hui à 13:35

patricktoulon à dit:
et dans le mode entier on bascule sur le dico pour excel<2016 et fonction unique pour excel >2016

Salut patricktoulon,
pour unique c'est pire que cela c'est excel >= 2021 . Le mieux c'est de tester si la fonction existe (erreur si la fonction n'existe pas et qu'on tente de l'exécuter )

Nullosse

patricktoulon · Aujourd'hui à 13:47

VB:

Sub b()
    Dim TabValeursUniques
 
    TabValeursUniques = TabVDicoUniquesColonneTS(ActiveSheet.ListObjects(1), 1, True) 'rien que les filtrés
    MsgBox "Filtré : " & vbCrLf & Join(TabValeursUniques, "|")
 
    TabValeursUniques = TabVDicoUniquesColonneTS(ActiveSheet.ListObjects(1), 1)
    MsgBox "sans les Filtre : " & vbCrLf & Join(TabValeursUniques, "|")
 
End Sub

Function TabVDicoUniquesColonneTS(TS As ListObject, index, Optional filter As Boolean = False)
    Dim dic As Object, RnG As Range
    Set dico = CreateObject("Scripting.Dictionary")
    If filter Then
        Set RnG = TS.DataBodyRange.Columns(index).SpecialCells(xlCellTypeVisible)
    Else
        Set RnG = TS.DataBodyRange.Columns(index)
    End If
    With RnG
        If filter Then
            For Each area In .Areas
                For Each Cel In area.Cells
                    dico(Cel.Value) = ""
                Next
            Next
            TabVDicoUniquesColonneTS = dico.keys
        Else
            If Val(Application.Version) >=2021 Then
                Dim T, I&
                T = RnG.Value
                For I = 1 To UBound(T): dico(T(I, 1)) = "": Next
                TabVDicoUniquesColonneTS = dico.keys
            Else
                T = WorksheetFunction.Unique(RnG)
                ReDim t2(1 To UBound(T))
                For I = 1 To UBound(T): t2(I) = T(I, 1): Next
                TabVDicoUniquesColonneTS = t2
            End If
        End If
    End With
End Function

normalement au dessus de 2021 elles l'ont toutes

etape1 bascule sur range complet ou specialcells si filter

Code:

  If filter Then
        Set RnG = TS.DataBodyRange.Columns(index).SpecialCells(xlCellTypeVisible)
    Else
        Set RnG = TS.DataBodyRange.Columns(index)
  End If

etape 2 bascule sur filtre dico ou range complet
si filter on passe tous en mode dico car on va boucler sur area-->area.cell (pas le choix)

Code:

 If filter Then
            For Each area In .Areas
                For Each Cel In area.Cells
                    dico(Cel.Value) = ""
                Next
            Next
            TabVDicoUniquesColonneTS = dico.keys

etape 2 bis on passe directe par unique pour les bersion d'excel >=2021 ou en mode dico pour les inférieurs

Code:

If Val(Application.Version) < 16 Then
                Dim T, I&
                T = RnG.Value
                For I = 1 To UBound(T): dico(T(I, 1)) = "": Next
                TabVDicoUniquesColonneTS = dico.keys
            Else
                T = WorksheetFunction.Unique(RnG.Columns(1))
                ReDim t2(1 To UBound(T))
                For I = 1 To UBound(T): t2(I) = T(I, 1): Next
                TabVDicoUniquesColonneTS = t2
            End If

on garantie ainsi que la methode employée est la plus rapide selon la version d'excel executante

nullosse · Aujourd'hui à 13:51

Le problème c'est que Application.Version renvoie 16 pour toutes les versions après la version 2016 (moi j'ai 16.0 avec mon Excel 2021)

nullosse · Aujourd'hui à 14:43

Bon voilà un code qui fonctionne chez moi :

VB:

Sub b()
    Dim TabValeursUniques, bm As New cBenchmark
    bm.Start
    TabValeursUniques = TabVDicoUniquesColonneTS(ActiveSheet.ListObjects(1), 1, True) 'rien que les filtrés
    Debug.Print "nb Valeurs uniques filtrées : " & CStr(UBound(TabValeursUniques) - LBound(TabValeursUniques) + 1)
    bm.TrackByName "Valeurs uniques filtrées"
    TabValeursUniques = TabVDicoUniquesColonneTS(ActiveSheet.ListObjects(1), 1)
    Debug.Print "nb Valeurs uniques : " & CStr(UBound(TabValeursUniques) - LBound(TabValeursUniques) + 1)
    bm.TrackByName "Valeurs uniques"
End Sub

Function TabVDicoUniquesColonneTS(TS As ListObject, index, Optional filter As Boolean = False)
    Dim dic As Object, RnG As Range
    Set Dico = CreateObject("Scripting.Dictionary")
    If filter Then
        Set RnG = TS.DataBodyRange.columns(index).SpecialCells(xlCellTypeVisible)
    Else
        Set RnG = TS.DataBodyRange.columns(index)
    End If
    With RnG
        If filter Then
            For Each area In .Areas
                For Each Cel In area.Cells
                    Dico(Cel.Value) = ""
                Next
            Next
            TabVDicoUniquesColonneTS = Dico.Keys
        Else
            Dim T, I&
            On Error GoTo Dico
                T = WorksheetFunction.Unique(RnG)
                ReDim t2(1 To UBound(T))
                For I = 1 To UBound(T): t2(I) = T(I, 1): Next
                TabVDicoUniquesColonneTS = t2
                GoTo Fin
Dico:          
                T = RnG.Value
                For I = 1 To UBound(T): Dico(T(I, 1)) = "": Next
                TabVDicoUniquesColonneTS = Dico.Keys
Fin:
        End If
    End With
End Function

Si il y a une erreur quand j'appelle la fonction WorksheetFunction.Unique , je me branche sur la partie Dico .
Voici le résultat chez moi avec mon Excel 2021 avec un tableau de 250000 chaînes aléatoires de 8 caractères. Il y a quatre doublons dans les chaînes et 6 valeurs filtrées:

nb Valeurs uniques filtrées : 6
nb Valeurs uniques : 249996
IDnr Name Time sum
0 Valeurs uniques filtrées 20 ms
1 Valeurs uniques 1,23 s

en utilisant la fonction unique.
Pour tester le mode dico , j'ai mis une fonction qui n'existe pas ( WorksheetFunction.UniK)
Résultat :

nb Valeurs uniques filtrées : 6
nb Valeurs uniques : 249996
IDnr Name Time sum
0 Valeurs uniques filtrées 22 ms
1 Valeurs uniques 2,78 s

j'ai une autre méthode pour récupérer les valeurs uniques qui me donne 500ms mais cela fait appel à des éléments externes.

Dudu2 · Aujourd'hui à 16:48

Bonjour les chercheurs de performance,
Une suggestion... pourquoi ne pas placer chaque Area en Table. Ça ira plus vite qu'en parcours de cellules.

VB:

    For Each area In .Areas
        T = area.Value
        For I = 1 To UBound(T): Dico(T(I, 1)) = "": Next
    Next area
    TabVDicoUniquesColonneTS = Dico.Keys

Dudu2 · Aujourd'hui à 17:48

Et une petite question...

VB:

Set RnG = TS.DataBodyRange.columns(index).SpecialCells(xlCellTypeVisible)

Quid des Areas si une autre colonne que la colonne demandée est aussi filtrée ?

Désolé de casser le moral de tout le monde !
Mais il faut sauver puis supprimer les filtres des toutes les colonnes sauf celle concernée, passer la fonction, puis restorer les filtres supprimés.

Dudu2 · 2025-09-16T18:48:12+0200

@laurent950,
J'ai trouvé à nouveau un cas particulier (que tu voulais que j'indique) où on ne peut pas récupérer la liste des critères de filtre.
Si, dans le filtre, on exclue que la valeur vide, on ne récupère que "<>" dans Criteria1 et Operator 0.

J'ai donc corrigé en conséquence la fonction de récupération des critères de filtres en Post #79 qui ne fonctionne que si:
l'Operator soit 0 (pas d'Operator) et que le filtre ne soit pas tout sauf valeurs vides, xlFilterValues ou xlOr.

Ceci dit, la plupart des cas de filtrage correspondent à cette contrainte et peut éviter un parcours de valeurs qui s'avèrera nécessaire si on doit parcourir les cellules visibles sous contrainte citée dans le Post précédent.

Effectuez une recherche sur Excel Downloads...

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

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

nullosse

XLDnaute Junior

patricktoulon

XLDnaute Barbatruc

nullosse

XLDnaute Junior

patricktoulon

XLDnaute Barbatruc

nullosse

XLDnaute Junior

nullosse

XLDnaute Junior

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Discussions similaires

Nous accordons de l'importance à votre vie privée