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.