Adapter code VBA, affiche PIvot Item
Bonjour;
j'ai trouvé un code sur internet qui me permet de faire ce que je veux (récupère la liste des pivot item sélectionnés dans une cellule)
cependant il faut le mettre dans la feuille directement
j'aimerais qu'on le place dans un module
merci d'avance
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
' Mettre à jour les filtres dans l'entête du Tableau Croisé Dynamique
'
' Target = Tableau croisé qui a été modifié
' -------------------------------------------------------------------------------------------------------
' Placer les sélections à droite des filtres du tableau croisé dynamique
' ----------------------------------------------------------------------
Call TitreFiltres(Target)
' Placer en commentaire les sélection des champs de lignes
' --------------------------------------------------------
Call CopyFilter2Comment(Target)
End Sub
Sub TitreFiltres(TCD As PivotTable)
'
' Afficher en clair les filtres sélectionnés dans l'entête du Tableau Croisé Dynamique
' TCD Tableau Croisé Dynamique à traiter
' ------------------------------------------------------------------
Dim C As Range
Dim C_Titre As Range ' Première cellule des titres (pour ranger les valeurs des filtres)
Dim Champ As PivotField
Dim Item As PivotItem
Dim C_Filtre As Range
Dim NbFiltres As Long ' Nb de champs dans les filtres
Dim NbVisible As Long, NbHidden As Long, DisplayVisible As Boolean ' Variable pour gérer le choix d'affichage des filtres
' -----------------------------------------------------------------------------------------------------------------------------------
'
' Pointer la zone de filtre du TCD
' --------------------------------
With TCD.TableRange2 ' Zone des filtres
On Error GoTo ExitSub
Set C_Filtre = Range(Cells(.Row, .Column).Address) ' Première cellule de la zone de filtre
NbFiltres = .PivotField.Position ' Nb de filtres
End With
'Range(Cells(1, 3).Address, C_Filtre.Offset(NbFiltres - 1, NbTcdColumn)).ClearContents ' nettoyer la zone des titres
Set C_Titre = C_Filtre.Offset(0, 2) ' Filtre en clair dans la colonne après les filtres
Set C_Filtre = Range(C_Filtre.Offset(0, 1), C_Filtre.Offset(NbFiltres - 1, 1)) ' Zone des filtres
' Parcourir tous les filtres
' --------------------------
For Each C In C_Filtre
Set Champ = TCD.PivotFields(C.PivotField.Caption) ' Champ de la selection
If Champ.AllItemsVisible Then
' Si pas de filtrage sur ce champ de filtre, afficher Tous "champ.name", avec s à la fin
' --------------------------------------------------------------------
Cells(C.Row, C_Titre.Column) = "Tous " & C.Offset(0, -1) & "s"
Else
' Sinon afficher en clair la liste des valeurs de fitre du champ de filtrage
' --------------------------------------------------------------------------
Cells(C.Row, C_Titre.Column) = vbNullString
' déterminer si la majorité des filtres est caché ou visible : Pour ensuite n'afficher dans le titre que la liste la plus courte
' ---------------------------------------------------------- soit la liste des visibles, soit la liste des cachés précédée de "Except"
For Each Item In Champ.PivotItems
If Item <> "(blank)" Then
Select Case Item.Visible
Case True: NbVisible = NbVisible + 1 ' compter les items sélectionnés dans le filtre
Case False: NbHidden = NbHidden + 1 ' Compter les items exclus dans le filtre
End Select
End If
Next Item
DisplayVisible = NbVisible <= NbHidden ' =True on affichera uniquement les filtres sélectionnés , = False on affichera les exclus précédé de "Except"
' Parcourir tous les éléments de filtrage
' --------------------------------------
For Each Item In Champ.PivotItems
If Item.Name <> "(blank)" Then ' Ne pas traiter les champs vides car ça plante sur l'objet item.visible
' Si le filtrage est actif, afficher sa valeur dans l'entête de l'onglet sur la même ligne
' ---------------------------------------------------------------------
If Cells(C.Row, C_Titre.Column) = vbNullString Then ' Première valeur trouvée
If Item.Visible = DisplayVisible Then ' traiter uniquement si le filtre est à l'état correspondant à celui défini plus haut
Select Case True
Case DisplayVisible: Cells(C.Row, C_Titre.Column) = Item.Caption ' Copier le nom du filtre actif
Case Else: Cells(C.Row, C_Titre.Column) = "Sauf : " & Item.Caption ' Copier le nom du filtre inactif précédé de "Except"
End Select
End If
Else
If Item.Visible = DisplayVisible Then
Cells(C.Row, C_Titre.Column) = Cells(C.Row, C_Titre.Column) & " , " & Item.Caption ' autres valeurs, faire précéder de " , " pour séparer les valeurs
End If
End If
End If
Next Item
End If
Next C
ExitSub:
End Sub
Sub CopyFilter2Comment(TCD As PivotTable)
' Afficher les filtres des colonnes dans un commentaire placé dans la cellule du titre de colonne
'
' Si le nb d'exclus est < au nb de sélecté : titre = "Sauf" et liste des exclus
' Sinon : titre = "Seulement" et liste des items sélectionnés
'
' ------------------------------------------------------------------------------------------------
Dim C As Range ' Cellule du champ à traiter
Dim Champ As PivotField ' Champ de la cellule
Dim Item As PivotItem ' Items du filtre
Dim SelectedItems As String ' Liste des items sélectionnés
Dim HiddenItems As String ' Liste des items cachés
Dim NbVisible As Long ' Nombre d'items sélectionnés
Dim NbHidden As Long ' Nombre d'item cachés
Const CommentHeightRatio = 15 ' Hauteur du PopUp commentaire par ligne de texte
' ------------------------------------------------------------------------------------------------
' Parcourir les champs de titre des lignes
' ----------------------------------------
Set C = CellFirstField(TCD) ' Pointer la première colonne des titres de lignes
If Not C Is Nothing Then
' Parcourir toutes les colonnes du tableau
' --------------------------------------
While C.PivotCell.PivotCellType = xlPivotCellPivotField
If Not C.Comment Is Nothing Then C.Comment.Delete ' Effacer d'abord le commentaire
SelectedItems = vbNewLine & " Seulement " & vbNewLine ' Entête du commentaire à créer quand la liste des sélectionnés est < liste des exclus
HiddenItems = vbNewLine & " Sauf " & vbNewLine ' Entête du commentaire à créer quand la liste des exclus est < liste des sélectionnés
NbVisible = 0
NbHidden = 0
' Parcourir tous les items du champ
' ---------------------------------
Set Champ = TCD.PivotFields(C.PivotField.Caption) ' Champ de la cellule
If Not Champ.AllItemsVisible Then
For Each Item In Champ.PivotItems
If Item <> "(blank)" Then ' ça plante si l'item est <Blank>
Select Case Item.Visible
Case True
' Quand l'item est visible, l'ajouter dans la liste des items sélectionnés
' ---------------------------------------------------------------------
SelectedItems = SelectedItems + vbNewLine + "- " + Item.Caption
NbVisible = NbVisible + 1
Case False
' Quand l'item n'est pas visible, l'ajouter dans la liste des items exclus
' ------------------------------------------------------------------------
HiddenItems = HiddenItems + vbNewLine + "- " + Item.Caption
NbHidden = NbHidden + 1
End Select
End If
Next Item
' Creer un commentaire dans la cellule
' ------------------------------------
C.AddComment
With C.Comment
.Shape.DrawingObject.Interior.ColorIndex = 35 ' Fond Vert
Select Case True
Case NbVisible < NbHidden
.Text SelectedItems ' Ranger la liste des items sélectionnés
.Shape.Height = (NbVisible + 3) * CommentHeightRatio ' Redimensionner la hauteur du PopUp commentaire
Case Else
.Text HiddenItems ' Ranger la liste des items exclus
.Shape.Height = (NbHidden + 3) * CommentHeightRatio ' Redimensionner la hauteur du PopUp commentaire
End Select
End With
End If
Set C = C.Offset(0, 1) ' Cellule suivante
Wend
End If
End Sub
Function CellFirstField(Pivot As PivotTable) As Range
'
' Renvoi la première cellule de la ligne des champs du tableau dynamique
'
' Pivot = Tableau croisé Dynamique
'
' -----------------------------------------------------------------------------------------------------------
Dim C As Range
Dim ws As Worksheet
' -----------------------------------------------------------------------------------------------------------
'
Set ws = ActiveWorkbook.Sheets(Pivot.Parent.Name) ' Onglet qui contient le tableau croisé
' Pointer la cellule du début du Tableau croisé
' ---------------------------------------------
Set C = ws.Range(Cells(Pivot.TableRange1.Row, Pivot.TableRange1.Column).Address)
On Error GoTo TcdError
' Rechercher la première cellule dans la colonne qui est dans une ligne de données
' --------------------------------------------------------------------------------
Do Until C.PivotCell.PivotCellType = xlPivotCellPivotItem
Set C = C.Offset(1, 0)
Loop
' La première cellule de la ligne des champs est la précédente
' -------------------------------------------------------------
Set CellFirstField = C.Offset(-1, 0)
Exit Function
TcdError:
' Le tcd est certainement vide
' ----------------------------
Set CellFirstField = Nothing
End Function
Pour ceux qui sohaitent j'ai trouver :
Dim SelectedItems As String ' Liste des items sélectionnés
With ActiveSheet.PivotTables("Tableau croisé dynamique 1").PivotFields("Semaine") 'mettre le filtre que vous souhaité
For i = 1 To .PivotItems.Count
If .PivotItems(i).Visible = True Then
SelectedItems = SelectedItems + "-" + .PivotItems(i)
End If
Next
End With