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

 

[Bernard_XLD]

malheureusement le shape(x).delete ne supprime pas les items du slicecaches

vraiment ?
essaies le fichier du post 43 et explique moi pourquoi cela fonctionne et recrée le même segment puisque j'ai désactivé la suppression postérieure

 

[patricktoulon]

re
oui j'ai bien une erreur à la 2 d création sur la ligne de creation add2........
après (c'est peut être ma version 2013 d'excel ) j'en sais rien en fait
le shapes(nomsegment).delete ne suffit pas
conclusion (encore une fois) comme je dis souvent ça mange pas de pain de sécuriser en vérifiant (voir supprimer)leur existence ou pas
au cas on est sur une version d'excel qui ne supprime pas les items du slicercaches correspondant au shapes(nomsegment)

 

[Bernard_XLD]

en fait, cette petite ligne fait la différence
Segment.Name = NomSegment
on renomme l'objet shape sans toucher à l'objet slidercache même si les deux objets ciblent le même objet
marrant que cela ne fonctionne pas sous 2013 mais cela doit fonctionner à partir de 2016

 

[Bernard_XLD]

oui j'ai bien une erreur à la 2 d création sur la ligne de creation add2

par curiosité, dans le fichier du post 43, essaies de créer le slidercache avec Workbook.SlicerCaches.Add au lieu de Add2 pour voir si ce n'est pas une mauvaise implémentation du Add2 à ses débuts (de mémoire la plupart des Add2 sont arrivés avec 2013 ou 2016)

 

[Bernard_XLD]

Patrick , je t'ai refait une version avec add pour voir

 

[patricktoulon]

re
je l'avais déja testé avec ma version
au punaise yes!! c'est exact!!!
avec add sur tbl sans pre supprimer les slicer ca match
ce qui est perturbant c'est que add c'est sur range normalement et add2 c'est sur listobject
et chez moi add fonctionne avec tbl qui est un listObject

 

[Bernard_XLD]

Alors comme pour les tris, utiliser Add au lieu de Add2 passe sur des versions plus anciennes tout en restant compatible avec les versions postérieures, ça fonctionne très bien aussi sur mon 365, bon à savoir mais cela ne m'étonne pas, j'ai souvent eu des problèmes de compatibilité avec Add2 qui , bien souvent, n'amène pas grand chose

 

[patricktoulon]

re
donc au final si add fonctionne chez vous autant utiliser add

Sub a()
    Dim TabValeursUniques() As Variant
    Dim S As String
    Dim i As Long
    Dim Index As Integer
    Index = Val(ActiveSheet.DrawingObjects(Application.Caller).Text)
    TabValeursUniques = TabValeursUniquesColonneTS(ActiveSheet.ListObjects(1), Index)
   
    If IsEmpty(TabValeursUniques) Then
        MsgBox "Echec récupération des valeurs uniques"
    Else
        For i = 1 To UBound(TabValeursUniques)
            S = S & TabValeursUniques(i) & vbCrLf
        Next i
        MsgBox S
    End If
End Sub


Function TabValeursUniquesColonneTS(Tbl As ListObject, TblNoColonne As Integer) As Variant()
    Dim SlicerItem As SlicerItem
    Dim Segment As Slicer
    Dim TabValeursUniques() As Variant
    Dim Workbook As Workbook
    Dim Worksheet As Worksheet
    Dim NomColonne As String
    Dim NomSegment As String
    Dim i As Long
    Dim sc As SlicerCache, sl As Slicer
   
    With Tbl
        Set Workbook = .Parent.Parent
        Set Worksheet = .Parent
        NomColonne = .HeaderRowRange(TblNoColonne)
        NomSegment = "VALEURS_UNIQUES"
        ' Création du slicer
        Set Segment = Workbook.SlicerCaches.Add(Tbl, NomColonne).Slicers.Add(Worksheet, , NomSegment, NomColonne, .Range.Left, .Range.Top, 100, 200)
       
        ' Récupération des valeurs uniques
        ReDim TabValeursUniques(1 To Segment.SlicerCache.SlicerItems.Count)
        For Each SlicerItem In Segment.SlicerCache.SlicerItems
            i = i + 1
            TabValeursUniques(i) = SlicerItem.Name
        Next SlicerItem
       
        ' Nettoyage : suppression du segment créé
        Segment.Delete
    End With
   
    ' Return value
    TabValeursUniquesColonneTS = TabValeursUniques
End Function

au final si c'est vraiment plus rapide qu'une boucle sur Dico ca pourrait faire une excellente fonction unique en vba

 

[Dudu2]

Un petite correction sur ce classeur pour le replace des espaces dans l'instruction:

For Each SlicerItem In Workbook.SlicerCaches("Segment_" & NomColonne).SlicerItems

Pour le reste je me repose sur vos super talents de segmenteurs !

 

[patricktoulon]

re
ben ça fonctionne avec Add pas de soucis
on peut répéter x fois les appels , il n'y a plus d'erreur

👍

mais n'oublie pas quand même qu'avec add visiblement le slicercaches n'est pas supprimé dans certaines version d'excel
donc si tu utilise "Add2" garde bien ça en tête

 

[Dudu2]

Par contre sur une grosse colonne (350.000 lignes) ça plante en mémoire insuffisante.

https://www.swisstransfer.com/d/06ee998d-4fa6-402b-9650-ee29ff1592be

Et si on remplace la boucle qui plante par un boucle indicée, ça dure très très longtemps.

 

[patricktoulon]

un derner petit detail @Dudu2 @Bernard_XLD
vu que le nm colonne peut avoir des caractères spéciaux ou espaces et donc renmmé automatiquement par excel

si vous ne voulez pas vous ennuyer avec le nm des telms du slicercaches
bouclez sur le slicercache de l'object lui même

With Segment.SlicerCache
            ReDim TabValeursUniques(1 To .SlicerItems.Count)
            For Each SlicerItem In .SlicerItems
                i = i + 1
                TabValeursUniques(i) = SlicerItem.Name
            Next SlicerItem
        End With

donc ca donne pouyr la fonction

Function TabValeursUniquesColonneTS(Tbl As ListObject, TblNoColonne As Integer) As Variant()
    Dim SlicerItem As SlicerItem
    Dim Segment As Object
    Dim TabValeursUniques() As Variant
    Dim Workbook As Workbook
    Dim Worksheet As Worksheet
    Dim NomColonne As String
    Dim NomSegment As String
    Dim WorkbookSaved As Boolean
    Dim i As Long
 
    With Tbl
        Set Workbook = .Parent.Parent
        Set Worksheet = .Parent
        WorkbookSaved = Workbook.Saved
        NomColonne = .HeaderRowRange(TblNoColonne)
        NomSegment = "VALEURS_UNIQUES"
     
        On Error Resume Next
        Worksheet.Shapes(NomSegment).Delete
        On Error GoTo 0
     
        With .Range
            Set Segment = Workbook.SlicerCaches.Add(Tbl, NomColonne).Slicers.Add( _
                                                    Worksheet, , NomColonne, NomColonne, .Left, .Top, 100, 200)
        End With
        Segment.Name = NomSegment
    End With
 
       
        With Segment.SlicerCache
            ReDim TabValeursUniques(1 To .SlicerItems.Count)
            For Each SlicerItem In .SlicerItems
                i = i + 1
                TabValeursUniques(i) = SlicerItem.Name
            Next SlicerItem
        End With
    
 
    'Clean up
    Segment.Delete
    Workbook.Saved = WorkbookSaved
 
    'Return value
    TabValeursUniquesColonneTS = TabValeursUniques
End Function

@Bernard_XLD bien recu l'erreur sur le nombre important

@Dudu2 pour la lecture
bien faire la différence entre
With Segment.SlicerCache 'ici pas besoins du nom du segment (puisque le parent c'est l'object lui même)
et
With Workbook.SlicerCaches' ici il faudra le nom du segment

 

[Dudu2]

@laurent950,
J'ai regardé ton code... 3 remarques:
- le critère (vide) ne sort pas (il pourrait sortir mais uniquement via le parcours),
- si je ne me trompe pas, tu parcours quand même les valeurs pour les ajouter dans le dico.

        ' Ajouter toutes les valeurs uniques de la colonne si elles ne sont pas déjà dans la collection
        lastRow = ws.Cells(ws.Rows.Count, i).End(xlUp).Row
        For Each cell In ws.Range(ws.Cells(2, i), ws.Cells(lastRow, i))

- pour Criteria1 / Operator / Critetia2, il peut y avoir des situations complexes (faut que je revoie ça pour expliquer)

 

[patricktoulon]

re
je viens de tester chez moi et déjà 50000 items c'est déj à dur dur pour excel

conclusion pour de grands tableaux je crois que rien ne vaut une boucle dico

Sub b()
    Dim t, dico As object
    Set dico = CreateObject("Scripting.Dictionary")
    With ActiveSheet.ListObjects(1)
        t = .DataBodyRange
        For i = 1 To UBound(t)
            dico(t(i, 1)) = ""
        Next
        t = dico.keys
    End With
    MsgBox Join(t, "|")
End Sub

j'ai testé et de dire que le temps d’exécution c'est le jour et la nuit serait euphémisme

50000 items avec un segment = 8,5 secondes ;on frôle déjà le white screen
50000 items avec boucle dico = quasiment instantané

au delà de 50000 item avec le slicer c'est la roulette russe
et avant c'est ce priver de la velocité d'une boucle dico

voilà

Patrick

 

[Dudu2]

conclusion pour de grands tableaux je crois que rien ne vaut une boucle dico

En effet, la boucle Dico, mais sur un table des valeurs comme tu as fait et pas sur les cellules.