Private Sub RéférentielTCD_Click()
' Procédure d'inventaire des filtres des TCD pour référence
' Déclaration des variables
Dim sht As Worksheet ' Feuille du classeur
Dim shtdst As Worksheet ' Feuille destination de l'inventaire
Dim lRow As Long ' Lignes
Dim lCols As Long ' Colonnes
Dim bAll As Boolean ' Booléen de "Tout" affichage
Dim strVis As String ' Etat de l'affichage visible ou pas de litem du PivotField
Dim strPF As String ' Nom du PivotField
Dim strPI As String ' Nom de l'item
Dim strLoc As String ' Location du PivotField
Dim strPTAddr As String ' Adresse du TCD
Dim strPTName As String ' Nom du TCD
Dim strSheetName As String ' Nom de la feuille
Dim StrPFAddr As String ' Adresse du PivotField
Dim lListItems As Long ' Liste des items
Dim PFItems As Double ' Nombre d'items des PivotFields
Dim strPFSourceName As String ' Source de la donnée
Dim MaxItems As Double ' Nombre maximum d'items à inventorier
' Désactivation des alertes et notifications interactives
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
' Nombre de colonnes dans le tableau
lCols = 9
' Dans ce classeur ...
With ThisWorkbook
'... Si la feuille "Référentiel TCD" existe (vérification via la fonction sheetExists)...
If sheetExists("Référentiel TCD") = True Then
'... Supression de la feuille existante ...
.Worksheets("Référentiel TCD").Delete
'... Puis création d'une nouvelle feuille à la fin du classeur
.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Référentiel TCD"
' Et si la feuille n'existe pas...
Else
' ... La créer à la fin du classeur
.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Référentiel TCD"
End If
' Définit la feuille destination comme étant la feuille "Référentiel TCD"
Set shtdst = .Sheets("Référentiel TCD")
' Définition de la première ligne du tableau
lRow = 1
' Dans la feuille destination...
With shtdst
' ... Créer les différentes colonnes
.Range(.Cells(lRow, 1), _
.Cells(lRow, lCols)).Value = Array("Feuille - Nom", _
"TCD - Name", _
"TCD - Adresse", _
"Location", _
"Champ - Nom", _
"Champ - Adresse", _
"Champ - Source", _
"Item", _
"Visible")
' Mettre la ligne des étiquettes en gras
.Rows(1).Font.Bold = True
End With
' Incrémenter la ligne d'une pour passer à la suivante
lRow = lRow + 1
' Définit le maximum d'items à inventorier au nombre de ligne possible dans la feuille
MaxItems = Rows.Count
' Pour chaque feuille du classeur...
For Each sht In .Worksheets
strSheetName = sht.Name
'... Pour chaque TCD de la feuille en cours...
For Each pvt In sht.PivotTables
' Pour chaque PivotField du TCD en cours...
For Each pvtField In pvt.PivotFields
' ... Définir le type
Select Case pvtField.Orientation
Case xlPageField: strLoc = "1 - Filter"
Case xlRowField: strLoc = "2 - Row"
Case xlColumnField: strLoc = "3 - Column"
Case Else: strLoc = "" 'only list row, column, filter
End Select
' Si le type n'est pas vide...
If strLoc <> "" Then
' Définit le nom du PivotField
strPF = pvtField.Name
' Si le PivotField n'est pas "Valeurs" (ou "Values pour Excel version UK)
If strPF <> "Valeurs" Or strPF <> "Valeurs" Then
' Définir le nom du TCD
strPTName = pvt.Name
' Définir l'adresse du TCD
strPTAddr = pvt.TableRange2.Address
' Définit la feuille du TCD
strSheetName = sht.Name
' Définir la source de données du PivotField
strPFSourceName = pvtField.SourceName
' Positionner la valeur booléanne du filtre Tous à Faux
bAll = False
' Si tous les PivotFields ne sont pas visibles, positionner le filtre d'affichage Tous à vrai
If pvtField.AllItemsVisible Then bAll = True
' Définit le nombre d'items
PFItems = pvtField.PivotItems.Count
lListItems = vbYes
If lListItems = vbYes Then
' Pour chaque item des PivotFileds...
For Each PvtItem In pvtField.PivotItems
' Définit sa visibilité...
strVis = ""
'... Son nom...
strPI = PvtItem.Name
'... Son adresse
StrPFAddr = pvtField.LabelRange.Address
' Si l'item est "blank" (vide)...
If strPI <> "(blank)" Then
'... Et si le nom du PivotField est Valeurs (ou Values en version UK)
If strPF <> "Valeurs" Or strPF <> "Values" Then
' Dans le cas où le filtre d'affichage...
Select Case bAll
' ... Est vrai...
Case True
'... Sa visibilité est à Oui
strVis = "Y"
' Sinon
Case Else
'... Si la visibilité est à faux alors la mettre à Oui
If PvtItem.Visible Then strVis = "Y"
End Select
' Dans la feuille de destination...
With shtdst
'... Renseigner chaque colonne
.Range(.Cells(lRow, 1), _
.Cells(lRow, lCols)).Value = Array(strSheetName, _
strPTName, _
strPTAddr, _
strLoc, _
strPF, _
StrPFAddr, _
strPFSourceName, _
strPI, _
strVis)
End With
' Incrémenter la ligne d'une pour passer à la suivante
lRow = lRow + 1
End If
End If
' Passer à l'item suivant
Next PvtItem
Else
strPI = PFItems & " Items"
Select Case bAll
Case True: strVis = "Y"
Case Else: strVis = "N/A"
End Select
' Dans la feuille de destination
With shtdst
' Renseigner les informations dans chaque colonne
.Range(.Cells(lRow, 1), _
.Cells(lRow, lCols)).Value = Array(strSheetName, _
strPTName, _
strPTAddr, _
strLoc, _
strPF, _
StrPFAddr, _
strPFSourceName, _
strPI, _
strVis)
End With
' Incrémenter la ligne d'une pour passer à la suivante
lRow = lRow + 1
End If
End If
End If
' Passer au prochain PivotField
Next pvtField
' Passer au prochain TCD
Next pvt
' Passer à la prochaine feuille
Next sht
' Mettre les données au format d'un tableau
With shtdst
.ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "tblFltr_" & Format(Now(), "mmddhhmmss")
.Range(.Cells(1, 1), .Cells(1, lCols)) _
.EntireColumn.AutoFit
.Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes
End With
End With
' Activation des alertes et notifications interactives
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
End Sub
