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

 

[Dudu2]

@ Bernard_XLD
C'est fou ! 2 classeurs avec strictement le même code. Un plante et pas l'autre !
Et c'est pas Workbook vs Wbk car même avec Wbk ça plantait aussi dans Classeur1.

 

[Bernard_XLD]

@Bernard_XLD

TabValeursUniques = TabValeursUniquesColonneTS(ActiveSheet.ListObjects(1), 2)

Même punition sur la colonne 2.
De toutes façons VBA sait différencier un nom de variable d'un type.
Regarde la pièce jointe 1222434

si le segment existe déjà, il faut le supprimer avant de lancer la macro ou ne pas le recréer s'il existe sinon erreur, le nom est forcément unique, pas deux segments du même nom

 

[Bernard_XLD]

c'est cela d'ailleurs, en chargeant ton fichier

 

[laurent950]

Voila @Dudu2 @Bernard_XLD

C'est fou ! 2 classeurs avec strictement le même code. Un plante et pas l'autre !
Et c'est pas Workbook vs Wbk car même avec Wbk ça plantait aussi dans Classeur1.

 

[Dudu2]

@Bernard_XLD,
Evidemment ! Merci d'avoir éclairci ce mystère qui commençait à me mettre les nerfs à vif 😱
Sur mon petit écran les Segments sont hors zone, pas visibles.

 

[Dudu2]

@laurent950,
Je regarde demain matin. Là, fatigue.
Bonne soirée à tous.

 

[patricktoulon]

Bonjour
Bien vu l'idée du segment et décompte des items du slicer

Maintenant
à voir si c'est plus performant finalement que une boucle sur le visiblerange du tableau avec un dico par exemple

 

[Bernard_XLD]

Bonjour Patrick

à voir si c'est plus performant finalement que une boucle sur le visiblerange du tableau avec un dico par exemple

Sur de gros tableaux, je le pense mais pas testé, Dudu2 pourra nous faire un retour

Bonne journée

 

[Dudu2]

Bonjour à tous,
@Bernard_XLD , je n'y comprends vraiment rien dans ces segments et slicers et les syntaxes correspondantes.
Je veux créer un segment de nom constant pour d'une part pouvoir le supprimer en amont et d'autre part pour éviter des noms improbables liés au noms des colonnes.
Mais voilà... je n'y arrive pas !

 

[patricktoulon]

Bonjour @Dudu2
je crois que tu confond la shape du segment et le slicer du segment
tu ne peux pas supprimer le segment sans supprimer son slicer

 

[patricktoulon]

re:
comme ceci tu devrais pouvoir relancer la sub a autant de fois sans pointer l'erreur

Sub a()
    Dim TabValeursUniques() As Variant
    Dim S As String
    Dim i As Long
    
    TabValeursUniques = TabValeursUniquesColonneTS(ActiveSheet.ListObjects(1), 2)
    
    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"
        
        '--- Suppression du segment et de ces slicers au cas ou la shape du segment créé récedemment n'a pas été supprimée
        On Error Resume Next 'on gère l'erreur pour les slicers et le shape in oneshot
        For Each sc In Workbook.SlicerCaches
            For Each sl In sc.Slicers
                If sl.Name = NomSegment Then
                    sc.Delete   ' supprime le cache + la shape
                    Exit For
                End If
            Next sl
        Next sc
        ' au cas ou on supprime la shape du segment  si y a une une carabistouille dans le potage
        Worksheet.Shapes(NomSegment).Delete
        On Error GoTo 0
        '--------------------------------------------
        
        ' Création du slicer
       Set Segment = Workbook.SlicerCaches.Add2(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éé(attention ici ca supprime uniquement la shapes(pas les slicers!!!!) )
        Segment.Delete
    End With
    
    'retour de la fonction'
    TabValeursUniquesColonneTS = TabValeursUniques
End Function

 

[Bernard_XLD]

je n'y comprends vraiment rien dans ces segments et slicers et les syntaxes correspondantes.

les segments sont très puissants pour des filtres en cascade quoiqu'un peu délicats à manipuler en vba parfois

Voila ton fichier modifié, j'ai désactive la suppression post du segment pour voir que cela fonctionne ainsi que ton test tableau qui ne fonctionne pas

Sub a()
    Dim TabValeursUniques() As Variant
    Dim S As String
    Dim i As Long
   
    TabValeursUniques = TabValeursUniquesColonneTS(ActiveSheet.ListObjects(1), 2)
   
'    If Not (Not TabValeursUniques) = 0 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

Sub aa()
    Dim Shape As Shape
   
    For Each Shape In ActiveSheet.Shapes
        MsgBox Shape.Name
        If Shape.Name = "VALEURS_UNIQUES" Then Shape.Delete
    Next Shape
End Sub

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 i As Long
   
    With Tbl
        Set Workbook = .Parent.Parent
        Set Worksheet = .Parent
        NomColonne = .HeaderRowRange(TblNoColonne)
        NomSegment = "VALEURS_UNIQUES"
       
        On Error Resume Next
        Worksheet.Shapes(NomSegment).Delete
        On Error GoTo 0
       
        With .Range
            Set Segment = Workbook.SlicerCaches.Add2(Tbl, NomColonne).Slicers.Add( _
                Worksheet, , NomColonne, NomColonne, .Left, .Top, 100, 200)
        End With
        Segment.Name = NomSegment
    End With
                               
    ReDim TabValeursUniques(1 To Workbook.SlicerCaches("Segment_" & NomColonne).SlicerItems.Count)
   
    For Each SlicerItem In Workbook.SlicerCaches("Segment_" & NomColonne).SlicerItems
        i = i + 1
        TabValeursUniques(i) = SlicerItem.Name
    Next SlicerItem
   
'    Segment.Delete
   
    'Return value
    TabValeursUniquesColonneTS = TabValeursUniques
End Function

 

[patricktoulon]

Bonjour @Bernard_XLD

@Dudu2 dans ce fichier je n'ai garde que la "sub a " dans la quelle je détermine la colonne par le texte de la shape

du coup j'ai fait les 4 colonnes

 

[Bernard_XLD]

et en précision, le nom d'un slicercache ne comporte pas d'espaces, si tu en as dans ton nom de colonne, il faut remplacer les espaces par _ dans nomcolonne avant d'appeler Workbook.SlicerCaches("Segment_" & NomColonne)
par exemple

Workbook.SlicerCaches("Segment_" & Replace(NomColonne, " ", "_"))

 

[patricktoulon]

re:
@Bernard_XLD

On Error Resume Next
        Worksheet.Shapes(NomSegment).Delete
        On Error GoTo 0

malheureusement le shape(x).delete ne supprime pas les items du slicecaches
c'est pour cela qu'il y a vait l'erreur au 2d lancement