Tableau croisé dynamique à selection variable
Bonjour à tous,
J'ai un problème avec un VBA et un tableau croisé dynamique.
J'ai un code qui ne marche pas, je dirai que c'est parce que la selection est trop importante mais je ne suis pas sur.
Voici le bout de code qui me pose problème:
Set sref = Sheets("production_avec_options")
k = sref.range("B" & Rows.Count).End(xlUp).Row
d = sref.Rows(1).Find("*", , , , xlByColumns, xlPrevious).Column
lastone = sref.Cells(k, d).Address
Sheets.Add after:=Sheets("production_avec_options")
ActiveSheet.Name = "TCDProduction"
sref.Select
sref.range("B1:" & lastone).Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
Selection, Version:=xlPivotTableVersion14). _
CreatePivotTable TableDestination:="TCDProduction!R1C1", TableName:= _
"Tableau croisé dynamique1", DefaultVersion:=xlPivotTableVersion14
La j'ai une incompatibilité de type 13.
Mais si je fais manuellement le TCD à partir de cet instant et que je l'enregistre voici le code:
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"production_avec_options!R1C2:R81771C6", Version:=xlPivotTableVersion14). _
CreatePivotTable TableDestination:="TCDProduction!R1C1", TableName:= _
"Tableau croisé dynamique1", DefaultVersion:=xlPivotTableVersion14
Ma "selection" dans le 1er code correspond exactement à : production_avec_options!R1C2:R81771C6
J'ai juste à faire : insertion>TCD et ca marche
Mais automatiquement il n'y arrive pas.
Et dans des cas ou j'ai une selection un peu plus petite le code marche avec "selection".
Est ce que quelqu'un aurait une solution pour avoir un code avec une selection variable?
D'avance merci.
Bonjour,
Essaie la procédure ci-dessous.
Si cela ne fonctionne pas, tu es prié de joindre un fichier.
Cdlt.
Option Explicit
Public Sub DEMO()
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rngPT As Range
Dim ptCache As PivotCache
Dim pt As PivotTable
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set wb = ActiveWorkbook
With wb
Set ws = .Worksheets("production_avec_options")
On Error Resume Next
.Worksheets("TCDProduction").Delete
On Error GoTo 0
.Worksheets.Add After:=.Worksheets(Worksheets.Count)
ActiveSheet.Name = "TCDProduction"
End With
Application.DisplayAlerts = True
With ws
lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
Set rngPT = .Cells(2).Resize(lastRow, lastCol - 1)
End With
Set ptCache = wb.PivotCaches.Create(xlDatabase, rngPT, 4)
Set pt = ptCache.CreatePivotTable(Cells(1), "PT_1", , 4)
pt.ManualUpdate = True
' code
' ...
' ....
pt.ManualUpdate = False
Cells(1).Select
Set pt = Nothing
Set ptCache = Nothing
Set rngPT = Nothing
Set ws = Nothing
Set wb = Nothing
End Sub
Je ne pense pas pouvoir passer mon fichier, car ce sont des données d'entreprises malheureusement. Et la partie ou ca foire, le fichier fait 30mo, je ne sais pas s'il y a une limite de taille.
Mais peux tu m'expliquer un peu plus ton code?
Spécialement cette ligne:
Set rngPT = .Cells(2).Resize(lastRow, lastCol - 1)
cela revient à faire une selection si je comprend?
Puis celles-ci:
Set ptCache = wb.PivotCaches.Create(xlDatabase, rngPT, 4)
Set pt = ptCache.CreatePivotTable(Cells(1), "PT_1", , 4)
pt.ManualUpdate = True
En prenant ton code tel quel, il bloque sur cette ligne:
Set ptCache = wb.PivotCaches.Create(xlDatabase, rngPT, 4)
Pour les memes raisons que précédemment: incompatibilité de type, erreur d'execution 13.
J'ai essayé avec seulement 60k lignes sélectionnées et cela marche, ton code et le miens aussi. (après plusieurs tests, les codes marches en dessous de 66k lignes).
Je pense vraiment qu'il s'agit d'un probleme de taille de la selection qu'il n'arrive pas à gérer tout seul, mais si je le fais "manuellement" ben cela marche...c'est très étrange.
Et j'ai essayé ton code avec:
Set ptCache = wb.PivotCaches.Create(xlDatabase, "production_avec_options!R1C2:R81771C5", 4)
Et ca marche..
Je ne sais pas du tout ou est le probleme....
Dans le doute, j'ai regardé, mais le fichier est bien en .xlsm sous 2010.
Re,
Sans fichier
ALT F11, ouvrir l'éditeur VBE.
Menu Affichage, Fenêtre Exécution (afficher).
Dans le code, sous
Set rngPT = .Cells(2).Resize(lastRow, lastCol - 1)
tu inscris
Debug.Print rngPT.Address
Tu lances la procédure.
Dans la fenêtre Exécution, tu auras l'adresse de rngPT. Correspond-elle à ta plage source du TCD à créer?
nota : Cells(2) correspond à B1...
J'ai voulu extraire et ne mettre que la partie qu'il manque mais il est supérieur à 300ko...
La selection est bien la bonne. Il n'y a pas de case vide qui pourrait poser problème..
J'essaye de trouver une solution pour trasnmettre le fichier.
Bonjour,
Mon code précédent fonctionne parfaitement dans ton fichier.
Cdlt.
Ben je comprend pas chez moi à chaque fois j'ai:
Erreur d'exécution '13':
Incompatibilité de type
Donc je suppose que c'est un problème de mémoire ou de capacité?
Re,
Peux-tu confirmer ta version Excel?
Cette procédure ne peut pas fonctionner avec une version Excel < 2010...
Oui
Excel 2010.
Version: 14.0.7015.1(32bits)
MS office pro plus 2010
Pour etre précis.
Re,
Mets tes données en tableau (mettre sous forme de tableau, dans le menu Accueil, dans le ruban).
Puis recopie ce nouveau code en lieu et place.
Exécute la procédure.
Une erreur? Et ou?
Option Explicit
Public Sub DEMO()
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
'Dim rngPT As Range
Dim lo As ListObject
Dim ptCache As PivotCache
Dim pt As PivotTable
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set wb = ActiveWorkbook
With wb
Set ws = .Worksheets("production_avec_options")
On Error Resume Next
.Worksheets("TCDProduction").Delete
On Error GoTo 0
.Worksheets.Add After:=.Worksheets(Worksheets.Count)
ActiveSheet.Name = "TCDProduction"
End With
Application.DisplayAlerts = True
'With ws
'lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
'lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
'Set rngPT = .Cells(2).Resize(lastRow, lastCol - 1)
'Debug.Print rngPT.Address
'End With
Set lo = ws.ListObjects(1)
'Set ptCache = wb.PivotCaches.Create(xlDatabase, rngPT, 4)
Set ptCache = wb.PivotCaches.Create(xlDatabase, lo.Range, 4)
Set pt = ptCache.CreatePivotTable(Cells(1), "PT_1", , 4)
pt.ManualUpdate = True
' code
' ...
' ....
pt.ManualUpdate = False
Cells(1).Select
Set pt = Nothing
Set ptCache = Nothing
Set lo = Nothing
'Set rngPT = Nothing
Set ws = Nothing
Set wb = Nothing
End Sub
Alors erreur au meme endroit:
Set ptCache = wb.PivotCaches.Create(xlDatabase, lo.Range, 4)
C'est vraiment bizarre quand meme, je le fais manuellement y a pas de probleme.
Mais en vba on dirait qu'il veut pas si y a plus de 65 537 lignes (excel 2003) ben il veut pas...
Re,
Ça n'a rien à voir avec le problème.
Une petite précision!
On parle bien d'une erreur dans le fichier que tu as joint.
Pas de ton vrai fichier.
Oui oui, je ne travail qu'avec ce petit fichier d'extraction.
Re,
Je ne sais pas quoi te dire de plus.
N'ayant aucune erreur
Un nouvel essai en intégrant les résultats du TCD.
Option Explicit
Public Sub DEMO()
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
'Dim rngPT As Range
Dim lo As ListObject
Dim ptCache As PivotCache
Dim pt As PivotTable
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set wb = ActiveWorkbook
With wb
Set ws = .Worksheets("production_avec_options")
On Error Resume Next
.Worksheets("TCDProduction").Delete
On Error GoTo 0
.Worksheets.Add After:=.Worksheets(Worksheets.Count)
ActiveSheet.Name = "TCDProduction"
End With
Application.DisplayAlerts = True
'With ws
'lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
'lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
'Set rngPT = .Cells(2).Resize(lastRow, lastCol - 1)
'Debug.Print rngPT.Address
'End With
Set lo = ws.ListObjects(1)
'Set ptCache = wb.PivotCaches.Create(xlDatabase, rngPT, 4)
Set ptCache = wb.PivotCaches.Create(xlDatabase, lo.Range, 4)
Set pt = ptCache.CreatePivotTable(Cells(1), "PT_1", , 4)
With pt
.ManualUpdate = True
.AddFields RowFields:="Long"
With .PivotFields("Qte")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
.Caption = ChrW(931) & " Qte"
End With
.RowAxisLayout xlTabularRow
.ManualUpdate = False
End With
Cells(1).Select
Set pt = Nothing
Set ptCache = Nothing
Set lo = Nothing
'Set rngPT = Nothing
Set ws = Nothing
Set wb = Nothing
End Sub
Meme résultats...
Merci pour ton aide.
Je vais essayer de faire en sorte d'avoir moins de données de base.
RE,
Je t'ai communiqué mon adresse email par MP.
On peut continuer sans les contraintes de taille de fichier.
A toi de voir.
Cdlt.
Je reviens juste sur un point.
Existe-t-il des versions de VBA?
Genre VBA 2003 avec un excel 2010?
J'ai vraiment l'impression que le probleme est la.
J'ai ouvert le fichier avec un excel 2013, ca marchait meme avec mon code original, enregistrer depuis cet excel (donc en version 2013), réouvert sur mon excel 2010...meme probleme qu'avant.
Voila ma version: VBA pour applications 7.0 version 1628.