Construire plusieur TCD sur une même feuille
Bonjour,
J'ai un soucis, je construis plusieurs TCD sur plusieurs pages (à chaque page son tableau) via le vba. et je voudrai les mettre tous sur une meme page.
voici un extrait de mon code, pour deux tableaux croisés par exmple :
Sub MacroTDC0()
'
Dim wshTCD0 As Worksheet
Dim PvtTCD0 As PivotTable
Set wshTCD0 = Worksheets("Generalite")
'Suppression de tous les TCD existants dans la feuille
For Each PvtTCD0 In wshTCD0.PivotTables
PvtTCD0.TableRange2.Clear
Next PvtTCD0
Set PvtTCD0 = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Données!A:CK") _
.CreatePivotTable(TableDestination:=wshTCD0.Range("B5"), TableName:="Generalite")
'Ajout des champs au TCD
With PvtTCD0
'Ajout d'une Colonne puis ajouter "genre" en valeur : .Orientation = xlDataField
With .PivotFields("genre")
.Orientation = xlRowField
.Orientation = xlDataField
.Position = 1
End With
'Ajout d'une Colonne puis ajouter "genre" en valeur : .Orientation = xlDataField
With .PivotFields("nationalite")
.Orientation = xlRowField
.Orientation = xlDataField
.Position = 1
End With
End With
' Supprimer la ligne "(vide)"
For i = 5 To 20
If Sheets("Generalite").Cells(i, 2) = "(vide)" Then
Sheets("Generalite").Cells(i, 2).Select
Selection.Delete Shift:=xlUp
End If
Next i
End Sub
Sub MacroTDC1()
'
'
'
' Diplômés par nationalité
'
'Dimension des variables
Dim wshTCD0 As Worksheet
Dim PvtTCD0 As PivotTable
'Affectation du TCD à la feuille "TCD automatique"
Set wshTCD0 = Worksheets("Generalite")
'Suppression de tous les TCD existants dans la feuille
' For Each PvtTCD0 In wshTCD0.PivotTables
' PvtTCD0.TableRange2.Clear
' Next PvtTCD0
'Ajout d'un TCD sur la feuille "TCD automatique"
Set PvtTCD0 = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Données!A:CK") _
.CreatePivotTable(TableDestination:=wshTCD0.Range("B13"), TableName:="Generalite")
'Ajout des champs au TCD
With PvtTCD0
'Ajout d'une Colonne puis ajouter "genre" en valeur : .Orientation = xlDataField
With .PivotFields("nationalite")
.Orientation = xlRowField
.Orientation = xlDataField
.Position = 1
End With
End With
' Supprimer la ligne "(vide)"
For i = 5 To 20
If Sheets("Generalite").Cells(i, 2) = "(vide)" Then
Sheets("Generalite").Cells(i, 2).Select
Selection.Delete Shift:=xlUp
End If
Next i
End Sub
Je vous remercie d'avance...
Bonjour,
Je ne sais pas vraiment ce que tu compte faire, mais regarde cette procédure et étudie là.
Sinon, tu joins un fichier à ta demande.
Cdlt.
Option Explicit
Dim wsData As Worksheet, wsPT As Worksheet
Dim rngData As Range
Dim ptCache As PivotCache
Dim pt As PivotTable
Dim i As Byte
Public Sub DEMO()
Application.ScreenUpdating = False
Set wsData = Worksheets("Données")
Set rngData = wsData.Cells(1).CurrentRegion
Set wsPT = Worksheets("Generalite")
'Suppression de tous les TCD existants dans la feuille
For Each pt In wsPT.PivotTables
pt.TableRange2.Clear
Next pt
Set ptCache = ActiveWorkbook.PivotCaches.Create(xlDatabase, rngData, 4)
Set pt = ptCache.CreatePivotTable(wsPT.Range("B5"), "TCD_1", , 4)
'Ajout des champs au TCD
With pt
.ManualUpdate = True
'Ajout d'une Colonne puis ajouter "genre" en valeur : .Orientation = xlDataField ???
With .PivotFields("genre")
.Orientation = xlDataField
.Function = xlSum
.Position = 1
.NumberFormat = "#,##0"
.Caption = "genre "
End With
'Ajout d'une Colonne puis ajouter "genre" en valeur : .Orientation = xlDataField ???
With .PivotFields("nationalite")
.Orientation = xlDataField
.Function = xlSum
.Position = 2
.NumberFormat = "#,##0"
.Caption = "nationalite "
End With
.ManualUpdate = False
End With
Set pt = ptCache.CreatePivotTable(wsPT.Range("F5"), "TCD_2", , 4)
With pt
.ManualUpdate = True
' code
'
.ManualUpdate = False
End With
' Supprimer la ligne "(vide)"
'For i = 5 To 20
'If wsPT.Cells(i, 2) = "(vide)" Then
'wsData.Cells(i, 2).Delete Shift:=xlUp
'End If
Next i
Set pt = Nothing
Set ptCache = Nothing
Set rngData = Nothing
Set wsPT = Nothing: Set wsData = Nothing
End Sub
Bonjour Jean-Eric,
C'est exactement ce que je veux, ton code est claire.
Mais quand je compile il y a un message d'errer qui sort :
Erreur d’exécution '13' : Incompatibilité type
Au niveau de Set ptCache = ActiveWorkbook.PivotCaches.Create(xlDatabase, rngData, 4)
je ne sais pas si cela est dû à ma version d'office ?
j'utilise office 2013...
Bonjour,
Ton profil indique 2010,
Tu peux tenter :
Set ptCache = ActiveWorkbook.PivotCaches.Create(xlDatabase, rngData, 5)
Set pt = ptCache.CreatePivotTable(wsPT.Range("B5"), "TCD_1", , 5)
Mais, je pense que l'erreur provient de rngData, donc de la plage définie par :
Set rngData = wsData.Cells(1).CurrentRegion
Toutes les colonnes doivent comporter un entête (un libellé, titre, ...)
Bonjour Jean-Eric,
Le problème est au niveau de l'intitulé de mes variables,
je les ai modifiés et toujours avec
Set ptCache = ActiveWorkbook.PivotCaches.Create(xlDatabase, rngData, 4), çà marche 10/10
Je te remercie, bonne journée a toi.
Salut Jean-Eric,
J'ai finalement tester l'ensemble des données de ma base mais cela gêner toujours le même type d'erreur : Erreur d'exécution '13': Incompatibilité de type.
Pourtant en supprimant toutes les autres colonnes (j'ai juste gardé les 3 colonnes pour essaie : specialite, regime et genre) j'ai arrivé à me gerer bien tous les TCD sur une meme page (comme je veux...Avec une colonne effectif(en nombre) et une autre en pourcentange).
Je vous met l'extrait du code :
Option Explicit
Dim wsData As Worksheet, wsPT As Worksheet
Dim rngData As Range
Dim ptCache As PivotCache
Dim pt As PivotTable
Dim i As Byte
Public Sub TDC1()
'Généralité
Application.ScreenUpdating = False
Set wsData = Worksheets("Données")
Set rngData = wsData.Cells(1).CurrentRegion
Set wsPT = Worksheets("Generalite")
'Suppression de tous les TCD existants dans la feuille
For Each pt In wsPT.PivotTables
pt.TableRange2.Clear
Next pt
With wsPT
Set ptCache = ActiveWorkbook.PivotCaches.Create(xlDatabase, rngData, 4)
'Diplômés par sexe :
Set pt = ptCache.CreatePivotTable(wsPT.Range("B5"), "TCD_1", , 4)
With pt
.ManualUpdate = True
' Effectif ou nombre
With .PivotFields("sexe")
.Orientation = xlRowField
.Orientation = xlDataField
.Position = 1
.Caption = "Effectif genre "
End With
With .PivotFields("sexe")
.Orientation = xlRowField
.Orientation = xlDataField
.Calculation = xlPercentOfColumn
.NumberFormat = "#,##0"
.Position = 1
.Caption = "Pourcentage genre(%) "
End With
.ManualUpdate = False
End With
Set pt = ptCache.CreatePivotTable(wsPT.Range("B15"), "TCD_2", , 4)
With pt
.ManualUpdate = True
'Ajout d'une Colonne puis ajouter "genre" en valeur : .Orientation = xlDataField ???
With .PivotFields("nationalite")
.Orientation = xlRowField
.Orientation = xlDataField
.Position = 1
.NumberFormat = "#,##0"
.Caption = "Effectif "
End With
With .PivotFields("nationalite")
.Orientation = xlRowField
.Orientation = xlDataField
.Calculation = xlPercentOfColumn
.NumberFormat = "#,##0"
.Position = 1
.Caption = "Pourcentage nationalité "
End With
.ManualUpdate = False
End With
Set pt = ptCache.CreatePivotTable(wsPT.Range("F5"), "TCD_3", , 4)
With pt
.ManualUpdate = True
With .PivotFields("regime")
.Orientation = xlRowField
.Orientation = xlDataField
.Position = 1
.NumberFormat = "#,##0"
.Caption = "Effectif "
End With
With .PivotFields("nationalite")
.Orientation = xlRowField
.Orientation = xlDataField
.Calculation = xlPercentOfColumn
.NumberFormat = "#,##0"
.Position = 1
.Caption = "Pourcentage regime "
End With
.ManualUpdate = False
End With
End With
Set pt = Nothing
Set ptCache = Nothing
Set rngData = Nothing
Set wsPT = Nothing: Set wsData = Nothing
End Sub
Re,
Je crains que tu sois obligé de joindre un fichier anonymisé si nécessaire
en précisant les résultats que tu souhaites.
Cdlt.
Je met ci-joint une présentation de la sortie que je souhaiterai avoir (feuille "TCD automatique1") dans ce classeur "Traitement", j'ai limité le nombre de colonnes (dans la feuille "Données"), ma base initiale à environ 110 colonnes (donc 110 variables).
et il y a une dizaine de TCD que je souhaite automatiser par feuille....
Bonjour,
Sans précisions sur les TCDs à créer, je te propose cette procédure, qui va te créer les TCDs à la volée, en fonction du nombre de colonnes en ligne 1.
Il serait judicieux d'avoir une liste des TCDs à créer...
A tester et à adapter dans ton vrai classeur.
Cdlt.
Option Explicit
'Option Private Module
Public Sub CreatePivotTables()
With Application
modeCalc = .Calculation
.Calculation = xlCalculationManual
'.EnableEvents = False
.ScreenUpdating = False
End With
Set wb = ThisWorkbook
With wb
Set wsData = .Worksheets("Données")
Set wsPT = .Worksheets("TCD automatique1")
End With
For Each pt In wsPT.PivotTables
pt.TableRange2.Clear
Next pt
With wsData
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rngData = .Cells(1).Resize(lastRow, lastCol)
End With
Set ptCache = wb.PivotCaches.Create(xlDatabase, rngData, 5)
ptCount = 1
r = 3
For c = 10 To lastCol
strField = wsData.Cells(1, c)
Set pt = ptCache.CreatePivotTable(wsPT.Cells(r, 1), "PT_" & ptCount, , 5)
With pt
.ManualUpdate = True
.AddFields RowFields:=Array("regime", "specialite"), _
ColumnFields:=wsData.Cells(1, c).Value
With .PivotFields(strField)
.Orientation = xlDataField
.Function = xlCount
.NumberFormat = "#,##0"
.Position = 1
.Caption = "Effectif "
End With
With .PivotFields(strField)
.Orientation = xlDataField
.Function = xlCount
.NumberFormat = "0.0%"
.Caption = "% Effectif"
.Position = 2
.Calculation = xlPercentOfRow
End With
.RowAxisLayout xlOutlineRow
.TableStyle2 = "PivotStyleMedium2"
.ErrorString = "-"
.DisplayErrorString = True
.ManualUpdate = False
End With
ptCount = ptCount + 1
r = wsData.Cells(Rows.Count, 1).End(xlUp).Row + 3
Next c
With wsPT
.Activate
.[A1].Select
End With
With Application
.Calculation = modeCalc
'.EnableEvents = True
.ScreenUpdating = True
End With
Set pt = Nothing
Set ptCache = Nothing
Set rngData = Nothing
Set wsPT = Nothing: Set wsData = Nothing
Set wb = Nothing
End Sub
Bonjour Jean-Eric,
Merci beaucoup, j'ai pu réussir avec le 1er code que tu m'avais envoyer.
Le problème était que mes TCDs sont placés cote à cote mais mais si je les place les uns après les autres çà marche super bien
Je te remercie.
Bonne journées
Crdlt,
Bonjour,
Pense à clore le sujet.
Cdlt.