Microsoft 365 Extraire les filtres d'une colonne ou d'un segment en VBA et les écrire dans une autre colonne.

LORIS-B

XLDnaute Nouveau
Bonjour à toutes et à tous !

Je vous sollicite car je suis bloqué:

J'ai un Tableau Excel classique situé dans la feuille "TDB" de mon classeur, à partir de la ligne n°40.
J'ai une colonne "A:A" qui contient tous les départements.
Cette colonne est pilotée par le Segment: "Segment_Département".
Je cherche à écrire dans une autre colonne tous les filtres qui sont à l'état actif quand une personne ce sert de ce segment.

Par exemple : L'utilisateur filtre les départements "01-Ain" + "25 - Doubs" via le segment ou le tableau --> Ecrire "01-Ain" dans la cellule "U01" et "25 - Doubs" dans la cellule "U02"

j'ai 18 départements en tout, donc ça écrirait de U01 à U18.

Impossible de trouver un code VBA...

Bien entendu, je ne peux pas vous partager le Tableau, il s'agit de données confidentielles...

Merci d'avance pour votre aide.
 

Staple1600

XLDnaute Barbatruc
Re, Bonjour TooFatBoy

En repassant
Et en attendant le fichier exemple
Ce bout de code fonctionne sur mon PC
(au moins pour un seul élément sélectionné sur le segment)
Code:
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
Dim i%
With ActiveWorkbook.SlicerCaches("Segment_ITEM1")
    For i = 1 To .SlicerItems.Count
        If .SlicerItems(i).Selected Then
        [E3] = "Valeur sélectionnée dans segment: " & .SlicerItems(i).Value
        End If
    Next i
End With
End Sub
 
Dernière édition:

Phil69970

XLDnaute Barbatruc
Bonjour @LORIS-B , Staple et TFB

Juste en passant aussi : ;)

Et d'une manière générale à lire les demandes j'ai l’impression que presque tous les demandeurs travaillent pour la défense nationale et ont des fichiers secret défense
==> si je te le montre je suis obligé de te tue
r 🤔 o_O 🤣

Pourtant quand je lis ceci :

Par exemple : L'utilisateur filtre les départements "01-Ain" + "25 - Doubs" via le segment ou le tableau --> Ecrire "01-Ain" dans la cellule "U01" et "25 - Doubs" dans la cellule "U02"

J'ai pas l'impression que l'on soit dans la défense nationale ;)
Ni dans le sensible surtout à la création d'un fichier...:oops:

le département 69 est dans le sensible mais pas celui que l'on imagine mais je crois que je suis hors sujet !!! :D

A croire que personne ne sait anonymiser un fichier avec une dizaine ou vingtaine de lignes pour le rendre compatible avec le RGPD et reflétant la structure et le nom des onglets du fichier original !!!

@Phil69970



 

Staple1600

XLDnaute Barbatruc
Bonjour @Phil69970

A croire que personne ne sait anonymiser un fichier
Pourtant Excel peut nous aider à le faire
(Mieux il nous permet de créer ex nihilo, tel un démiurge azimuté, des données exemples non confidentielles)
;)
Et j'ai posté plein de bout de code sur XLD en ce sens au fil des des ans.
VB:
Sub Confidences_pour_Confidences()
Range("A1:F1").FormulaR1C1 = "=""COLONNE_""&CHAR(64+COLUMN())"
Range("A2:A35").FormulaR1C1 = "=MOD(ROW(),4)+13"
Range("B2:F35").FormulaR1C1 = "=REPT(CHAR(RANDBETWEEN(65,90)),MOD(COLUMN(),2)+3)&ROW()*COLUMN()"
Range("A1:F35") = Range("A1:F35").Value
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$F$35"), , xlYes).Name = "BazingA"
End Sub
Faut croire qu'ils passent inaperçus ;)

PS: Ceci dit, c'est pas évident de tâter du Slicer en VBA ;)
 

Staple1600

XLDnaute Barbatruc
Re

Toujours sans fichier exemple et pour occuper mon dimanche pluvieux
Une version qui liste plusieurs valeurs sélectionnées sur le segment
(code dans un module standard)
VB:
Public Sub Afficher_Filtres_TCD()
Dim slCache As SlicerCache, i%, strG$, tmp$, vResult
Set slCache = ActiveWorkbook.SlicerCaches("Segment_ITEM1")
    For i = 1 To slCache.SlicerItems.Count
        With slCache.SlicerItems(i)
            If .Selected = True Then
            strG = strG & .Value & ","
            End If
        End With
    Next i
tmp = Left(strG, Len(strG) - 1)
vResult = Split(tmp, ",")
Range("E:E") = ""
Range("E3").Resize(UBound(vResult) + 1) = Application.Transpose(vResult)
End Sub
et dans le code de la feuille idoine
VB:
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
Afficher_Filtres_TCD
End Sub

Je m'arrête là pour le moment.

Ci-dessous mon terrain de jeu dans Excel
Segement.PNG
 

Staple1600

XLDnaute Barbatruc
@LORIS-B,

A partir de ton fichier fichier exemple, ceci semble fonctionner
Code:
Sub Afficher_Filtres_TCD_BIS()
Dim sl As SlicerCache, sItem As SlicerItem, Key
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each sl In ThisWorkbook.SlicerCaches
    For Each sItem In sl.SlicerItems
    If sItem.Selected Then
    .Item(sItem.Value) = 1
    End If
    Next
Next
'adapter selon besoin
Range("C1:C18") = ""
Range("C1").Resize(.Count) = Application.Transpose(.Keys)
End With
End Sub
Et dans le code d'un CommandButton
VB:
Private Sub CommandButton1_Click()
Call Afficher_Filtres_TCD_BIS
End Sub
Résultat obtenu ci-dessous:
Segment_2.PNG
(j'ai mis le résultat en colonne C plutôt qu'en colonne UO pour mieux voir lors des tests)

PS:Ne fonctionnera que si dans le classeur il y a qu'un seul segment, et pas de TCD
(point à vérifier)
 

LORIS-B

XLDnaute Nouveau
@LORIS-B,

A partir de ton fichier fichier exemple, ceci semble fonctionner
Code:
Sub Afficher_Filtres_TCD_BIS()
Dim sl As SlicerCache, sItem As SlicerItem, Key
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each sl In ThisWorkbook.SlicerCaches
    For Each sItem In sl.SlicerItems
    If sItem.Selected Then
    .Item(sItem.Value) = 1
    End If
    Next
Next
'adapter selon besoin
Range("C1:C18") = ""
Range("C1").Resize(.Count) = Application.Transpose(.Keys)
End With
End Sub
Et dans le code d'un CommandButton
VB:
Private Sub CommandButton1_Click()
Call Afficher_Filtres_TCD_BIS
End Sub
Résultat obtenu ci-dessous:
Regarde la pièce jointe 1167360
(j'ai mis le résultat en colonne C plutôt qu'en colonne UO pour mieux voir lors des tests)

PS:Ne fonctionnera que si dans le classeur il y a qu'un seul segment, et pas de TCD
(point à vérifier)
Re,
Merci ça fonctionne niquel !
Malheureusement, j'ai 11 segments différents dans mon TDB.
Tu pense que cette méthode fonctionnerait sur le filtre en colonne A du Tableau au lieu du Segment ?
Car en soit ça reviendrait au même, mais ça serait peut-être moins compliqué du coup.

Si pas possible je clôture le post et je trouverais bien un autre moyen (si j'abandonne pas avant)
Merci pour tes réponses rapide !
 

Staple1600

XLDnaute Barbatruc
Re

Déjà cela fonctionne sur ton fichier exemple
C'est déjà un bon point, non ?
C'est pas du malheur ;)

C'est effectivement plus simple de s'affranchir des segments et de récupérer les items de l'Autofilter.

Pourquoi abandonner ?
C'est dimanche ;)

On a le temps, non ?
 

LORIS-B

XLDnaute Nouveau
Re

Déjà cela fonctionne sur ton fichier exemple
C'est déjà un bon point, non ?
C'est pas du malheur ;)

C'est effectivement plus simple de s'affranchir des segments et de récupérer les items de l'Autofilter.

Pourquoi abandonner ?
C'est dimanche ;)

On a le temps, non ?
Carrément que c'est un bon point ! :)

Disons que j'ai de maigres compétences en VBA et que je bloque depuis un moment ^^'

C'est vrais, on a le temps :)
 

Staple1600

XLDnaute Barbatruc
Re

Donc issu de mes archives (code glané jadis sur le web anglophone)
(test OK sur ton fichier exemple)
Ici on récupère les critères du filtre automatiques des cellules filtrées
VB:
Sub Recuperer_Criteres_Filtres_LO()
Dim Value, Arr, c%
ReDim Arr(0)
With ActiveSheet.ListObjects(1).AutoFilter
    If .FilterMode Then
    For c = 1 To .Filters.Count
    If .Filters(c).On Then
    If IsArray(.Filters(c).Criteria1) Then
        For Each Value In .Filters(c).Criteria1
        Arr(UBound(Arr)) = Mid(Value, 2, Len(Value))
        ReDim Preserve Arr(UBound(Arr) + 1)
        Next
        ReDim Preserve Arr(UBound(Arr) - 1)
        Else
        Arr(UBound(Arr)) = .Filters(c).Criteria1
        ReDim Preserve Arr(UBound(Arr) + 1)
        On Error Resume Next
        Arr(UBound(Arr)) = .Filters(c).Criteria2
        If Err <> 0 Then ReDim Preserve Arr(UBound(Arr) - 1)
        On Error GoTo 0
    End If
    End If
    Next
    Else
    End If
End With
Cells(1, "C").Resize(18) = ""
Cells(1, "C").Resize(UBound(Arr) + 1).Value = Application.Transpose(Arr)
End Sub
 

LORIS-B

XLDnaute Nouveau
Re

Donc issu de mes archives (code glané jadis sur le web anglophone)
(test OK sur ton fichier exemple)
Ici on récupère les critères du filtre automatiques des cellules filtrées
VB:
Sub Recuperer_Criteres_Filtres_LO()
Dim Value, Arr, c%
ReDim Arr(0)
With ActiveSheet.ListObjects(1).AutoFilter
    If .FilterMode Then
    For c = 1 To .Filters.Count
    If .Filters(c).On Then
    If IsArray(.Filters(c).Criteria1) Then
        For Each Value In .Filters(c).Criteria1
        Arr(UBound(Arr)) = Mid(Value, 2, Len(Value))
        ReDim Preserve Arr(UBound(Arr) + 1)
        Next
        ReDim Preserve Arr(UBound(Arr) - 1)
        Else
        Arr(UBound(Arr)) = .Filters(c).Criteria1
        ReDim Preserve Arr(UBound(Arr) + 1)
        On Error Resume Next
        Arr(UBound(Arr)) = .Filters(c).Criteria2
        If Err <> 0 Then ReDim Preserve Arr(UBound(Arr) - 1)
        On Error GoTo 0
    End If
    End If
    Next
    Else
    End If
End With
Cells(1, "C").Resize(18) = ""
Cells(1, "C").Resize(UBound(Arr) + 1).Value = Application.Transpose(Arr)
End Sub
Merci Ca Fonctionne !!
Par contre, chaud le code !
J'ai l'impression que quand il y a que deux lignes de remplies il y a le symbole "=" qui s'ajoute devant le département.
A partir du 3eme le symbole s'en va.
Excel nous troll toujours !
 

Pièces jointes

  • Capture.PNG
    Capture.PNG
    1.8 KB · Affichages: 17

Discussions similaires

Statistiques des forums

Discussions
315 002
Messages
2 115 239
Membres
112 354
dernier inscrit
michaelDL