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

LORIS-B · 2 Avril 2023

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 · 2 Avril 2023

Bonjour le fil

En passant

le demandeur¸ que nenni¸ à dit:
Bien entendu, je ne peux pas vous partager le Tableau, car je peux prendre le temps de créer un fichier exemple allégé sans aucunes données confidentielles...

C'est pourtant indolore et pas si chronophage.

TooFatBoy · 2 Avril 2023

Bonjour le fil

En passant

LORIS-B à dit:
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...

Une liste de 18 départements ne semble pourtant pas si confidentielle que ça.

Staple1600 · 2 Avril 2023

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

Phil69970 · 2 Avril 2023

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 tuer

Pourtant quand je lis ceci :

LORIS-B à dit:
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...

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

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 · 2 Avril 2023

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 · 2 Avril 2023

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

LORIS-B · 2 Avril 2023

Staple1600 à dit:
Bonjour le fil

En passant

C'est pourtant indolore et pas si chronophage.

Bonjour, voici un exemple en PJ.

Staple1600 · 2 Avril 2023

Re

Merci pour le fichier exemple
Qui m'a permis de me rendre compte que le code que j'ai proposé ne fonctionne qu'avec un TCD
(tel que rédigé)
Et pas avec un tableau structuré

Staple1600 · 2 Avril 2023

@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:

(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 · 2 Avril 2023

Staple1600 à dit:
@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 · 2 Avril 2023

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 · 2 Avril 2023

Staple1600 à dit:
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 · 2 Avril 2023

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 · 2 Avril 2023

Staple1600 à dit:

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 !

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

Staple1600

XLDnaute Barbatruc

TooFatBoy

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Phil69970

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

LORIS-B

XLDnaute Nouveau

Pièces jointes

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

LORIS-B

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

LORIS-B

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

LORIS-B

XLDnaute Nouveau

Pièces jointes

Discussions similaires