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

L

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.
 
Trier par date Trier par votes
Staple1600

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:
Vote positif 0 Vote négatif
Phil69970

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 tuer 🤔 o_O 🤣

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"
Cliquez pour agrandir...

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



 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour @Phil69970

A croire que personne ne sait anonymiser un fichier
Cliquez pour agrandir...
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 ;)
 
Vote positif 0 Vote négatif
Staple1600

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
 
Vote positif 0 Vote négatif
Staple1600

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)
 
Vote positif 0 Vote négatif
L

LORIS-B

XLDnaute Nouveau
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)
Cliquez pour agrandir...
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 !
 
Vote positif 0 Vote négatif
Staple1600

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 ?
 
Vote positif 0 Vote négatif
L

LORIS-B

XLDnaute Nouveau
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 ?
Cliquez pour agrandir...
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 :)
 
Vote positif 0 Vote négatif
Staple1600

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
 
Vote positif 0 Vote négatif
L

LORIS-B

XLDnaute Nouveau
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
Cliquez pour agrandir...
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: 14
Vote positif 0 Vote négatif

Discussions similaires

L
  • Question
XL 2021 Appliquer plusieurs filtres numériques "entre" sur une colonne excel
Réponses
6
Affichages
178
Cousinhub
Cousinhub
B
  • Résolu(e)
XL 2021 lancer une macro quand je clic sur une valeur d'un segment
Réponses
7
Affichages
1 K
beurhou
B
Fred S.
  • Résolu(e)
XL 2016 Extraire les données d'une colonne pour les metrre dans une autre colonne
Réponses
13
Affichages
592
Fred S.
Fred S.
D
  • Question
XL 2016 [VBA] Mettre à jour un segment en fonction d'une liste filtrée
2
Réponses
17
Affichages
1 K
Hasco
Hasco
F
  • Question
XL 2021 sélection de colonne et ordonnancement des colonnes en déclarant en variable les entêtes
Réponses
2
Affichages
140
ftpo69
F
M
  • Question
Microsoft 365 Extraire une valeur de fin dans une colonne
Réponses
4
Affichages
248
Staple1600
Staple1600
C
  • Question
Autres Ajouter formule dans une colonne en VBA
Réponses
4
Affichages
408
job75
job75
R
  • Question
Microsoft 365 RESOLU Utilisation Segments avec sélections multiples automatiques
Réponses
5
Affichages
1 K
richard31
R
O
  • Question
Autres VBA test et action selon valeur de la première cellule visible en colonne A après un tri
Réponses
8
Affichages
451
Oko
O
B
  • Question
XL 2013 Automatiser une formule sur les nouvelles lignes insérées en fonction d'une recherche sur les enregistrements
Réponses
9
Affichages
224
bedley
B

Membres actuellement en ligne

19 membres et 291 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 192
Messages
2 086 054
Membres
103 110
dernier inscrit
Privé