Créer TCD base évolutive [Résolu/Fermé]

Signaler
Messages postés
143
Date d'inscription
vendredi 29 mai 2015
Statut
Membre
Dernière intervention
5 septembre 2020
-
Messages postés
143
Date d'inscription
vendredi 29 mai 2015
Statut
Membre
Dernière intervention
5 septembre 2020
-
Bonjour,

Je cherche à réutiliser ce code qui m'a été donné sur ce forum et qui fonctionnait très bien, pour l'adapter à un autre fichier mais je rencontre un blocage.

Sub CreerTCD1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo GestionErreur
Sheets("globalJANVIER").Select
LigDeb = 1
DerLig = [A100000].End(xlUp).Row
ColDeb = 1
DerCol = [C1].End(xlToLeft).Column
Set DonneesSource = Range(Cells(LigDeb, ColDeb), Cells(DerLig, DerCol))
If Not Sheets("JANVIER") Is Nothing Then SupprimerLeTCDTRANSPORTEURS

CreationTCD:
Sheets("JANVIER").Tab.ColorIndex = 40

'utiliser l'enregistreur de macro pour la suite, puis coller ci-dessous
'puis dans la première ligne, remplacer les termes suivants par exemple:"SourceData:=B6:G30" par "SourceData:=DonneesSource"
'**********************************************************************************************************************************

Range("B2").Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
DonneesSource, Version:=xlPivotTableVersion15). _
CreatePivotTable TableDestination:="JANVIER!R2C2", TableName:= _
"LeTCDTRANSPORTEURS", DefaultVersion:=xlPivotTableVersion15
With ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").PivotFields( _
"Transporteurs")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").AddDataField ActiveSheet. _
PivotTables("LeTCDTRANSPORTEURS").PivotFields( _
"Somme de Nombre de transport"), "Somme de Somme de Nombre de transport", xlSum
ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").AddDataField ActiveSheet. _
PivotTables("LeTCDTRANSPORTEURS").PivotFields("Somme de Km Parcourus"), _
"Somme de Somme de Km Parcourus", xlSum
Range("C2").Select
ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").DataPivotField.PivotItems( _
"Somme de Somme de Km Parcourus").Caption = "Km Parcourus"
Range("D2").Select
ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").DataPivotField.PivotItems( _
"Somme de Somme de Nombre de transport").Caption = "Nombre de transport"
Range("B2").Select
ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").CompactLayoutRowHeader = _
"Analyse Transports"
Range("B2").Select
'******************************************************************************************************************************************
Exit Sub
GestionErreur:
SupprimerLeTCDTRANSPORTEURS
On Error GoTo 0
On Error Resume Next
GoTo CreationTCD

End Sub
Sub SupprimerLeTCDTRANSPORTEURS()
On Error GoTo Sortie
Application.DisplayAlerts = False
With Sheets("JANVIER")
.Select
Set Plage = .Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 4))
Plage.Clear
End With
Sortie:
End Sub


VBA m'indique une erreur à ce niveau du code
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
DonneesSource, Version:=xlPivotTableVersion15). _
CreatePivotTable TableDestination:="JANVIER!R2C2", TableName:= _
"LeTCDTRANSPORTEURS", DefaultVersion:=xlPivotTableVersion15


"erreur definie par l'application ou par l'objet"

Une idée pour m'aider ?

Merci :)


1 réponse

Messages postés
2172
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
9 novembre 2020
297
Bonjour,
L'erreur ne vient pas de là, mais plutôt du fait qu'il ne peut pas effacer le TCD, il faut le supprimer pour le recréer à nouveau.
Dans votre cas, au départ, s'il détecte la feuille "JANVIER", le programme est redirigé vers la gestion d'erreur qui veut effacer le contenu de cette feuille, mais le TCD est toujours présent. A la sortie de la gestion d'erreur, on reprend le programme principal à l'étiquette "CreationTCD", et on lui demande de recréer le TCD, or comme celui-ci est toujours présent, cela crée une nouvelle erreur et comme la gestion d'erreur n'est pas réinitialisée, le programme plante sur la ligne de création du TCD.
Le plus simple est de supprimer le TCD existant et de le créer à nouveau.

ce qui donne à partir de l'étiquette:
CreationTCD:
    Sheets.Add.Name = "JANVIER"
    Sheets("JANVIER").Tab.ColorIndex = 40

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        DonneesSource, Version:=xlPivotTableVersion15). _
        CreatePivotTable TableDestination:="JANVIER!R2C2", TableName:= _
        "LeTCDTRANSPORTEURS", DefaultVersion:=xlPivotTableVersion15
    
    Sheets("JANVIER").Select
    Cells(3, 2).Select
    ActiveWorkbook.ShowPivotTableFieldList = True
    Range("B2").Select
    ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").AddDataField ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").PivotFields("Somme de Nombre de transport"), "Somme de Somme de Nombre de transport", xlSum
    ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").AddDataField ActiveSheet. _
        PivotTables("LeTCDTRANSPORTEURS").PivotFields("Somme de Km Parcourus"), "Somme de Somme de Km Parcourus", xlSum
    Range("C2").Select
    ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").DataPivotField.PivotItems("Somme de Somme de Km Parcourus").Caption = "Km Parcourus"
    Range("D2").Select
    ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").DataPivotField.PivotItems("Somme de Somme de Nombre de transport").Caption = "Nombre de transport"
    Range("B2").Select
    ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").CompactLayoutRowHeader = "Analyse Transports"
    Range("B2").Select
   '******************************************************************************************************************************************
Exit Sub
GestionErreur:
    SupprimerLeTCDTRANSPORTEURS
    On Error GoTo 0
    On Error Resume Next
    GoTo CreationTCD
End Sub

Sub SupprimerLeTCDTRANSPORTEURS()
    On Error GoTo Sortie
    Application.DisplayAlerts = False
    Sheets("JANVIER").Delete
Sortie:
End Sub


A tester
Cdlt
Messages postés
143
Date d'inscription
vendredi 29 mai 2015
Statut
Membre
Dernière intervention
5 septembre 2020

Bonjour,

Merci pour votre réponse. Je viens de tester votre solution mais le code plante au niveai de la ligne
   ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").AddDataField ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").PivotFields("Somme de Nombre de transport"), "Somme de Somme de Nombre de transport", xlSum


avec le msg d'erreur suivant : Impossible de lire la propriété PivotFields de la classe PivotTable.

Sub TOTAL_JANV()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo GestionErreur
Sheets("globalJANVIER").Select
LigDeb = 1
DerLig = [A100000].End(xlUp).Row
ColDeb = 1
DerCol = [C1].End(xlToLeft).Column
Set DonneesSource = Range(Cells(LigDeb, ColDeb), Cells(DerLig, DerCol))
If Not Sheets("JANVIER") Is Nothing Then SupprimerLeTCDTRANSPORTEURS

CreationTCD:
Sheets.Add.Name = "JANVIER"
Sheets("JANVIER").Tab.ColorIndex = 40

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
DonneesSource, Version:=xlPivotTableVersion15). _
CreatePivotTable TableDestination:="JANVIER!R2C2", TableName:= _
"LeTCDTRANSPORTEURS", DefaultVersion:=xlPivotTableVersion15

Sheets("JANVIER").Select
Cells(3, 2).Select
ActiveWorkbook.ShowPivotTableFieldList = True
Range("B2").Select
ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").AddDataField ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").PivotFields("Somme de Nombre de transport"), "Somme de Somme de Nombre de transport", xlSum
ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").AddDataField ActiveSheet. _
PivotTables("LeTCDTRANSPORTEURS").PivotFields("Somme de Km Parcourus"), "Somme de Somme de Km Parcourus", xlSum
Range("C2").Select
ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").DataPivotField.PivotItems("Somme de Somme de Km Parcourus").Caption = "Km Parcourus"
Range("D2").Select
ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").DataPivotField.PivotItems("Somme de Somme de Nombre de transport").Caption = "Nombre de transport"
Range("B2").Select
ActiveSheet.PivotTables("LeTCDTRANSPORTEURS").CompactLayoutRowHeader = "Analyse Transports"
Range("B2").Select

'******************************************************************************************************************************************
Exit Sub
GestionErreur:
SupprimerLeTCDTRANSPORTEURS
On Error GoTo 0
On Error Resume Next
GoTo CreationTCD
End Sub

Sub SupprimerLeTCDTRANSPORTEURS()
On Error GoTo Sortie
Application.DisplayAlerts = False
Sheets("JANVIER").Delete
Sortie:
End Sub


Merci pour votre aide
Messages postés
143
Date d'inscription
vendredi 29 mai 2015
Statut
Membre
Dernière intervention
5 septembre 2020

voici un lien vers une partie de mon fichier si ça peut aider http://www.cjoint.com/c/GAlqPqL3DfR
Messages postés
2172
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
9 novembre 2020
297 >
Messages postés
143
Date d'inscription
vendredi 29 mai 2015
Statut
Membre
Dernière intervention
5 septembre 2020

Bonjour
Désolé pour la réponse tardive, mais j'étais absent toute la semaine.
l'erreur viens de la détection de la dernière colonne du tableau.
pour le tableau de gauche, remplacez
DerCol = [C1].End(xlToLeft).Column

par
DerCol = [A1].End(xlToRight).Column

A tester
Cdlt
Messages postés
143
Date d'inscription
vendredi 29 mai 2015
Statut
Membre
Dernière intervention
5 septembre 2020
>
Messages postés
2172
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
9 novembre 2020

Parfait ça fonctionne, Merci beaucoup !