Copier un TCD en Tableau simple sur autre feuille

Bonjour

Je souhaiterai copier un TCD (PivotTable1) present sur ma feuille (Filter) vers la feuille (Email) mais sous forme d'une table nommé... afin de pouvoir l'utiliser dans un flow.

Cela fait plusieurs heures que je me prends la tête avec cela sans résultats.

Private Sub CommandButton1_Click()
Dim ws As Worksheet
    Dim pvt As PivotTable
    Dim tbl As ListObject
    Dim rng As Range

    'Set ws = ThisWorkbook.Worksheets("Filter")

    Set pvt = ws.PivotTables("PivotTable1")

    Set rng = pvt.TableRange1

    Set tbl = ThisWorkbook.Worksheets("Email").ListObjects.Add(xlSrcRange, rng, xlYes)

    tbl.Range.Copy Destination:=ThisWorkbook.Worksheets("Email").Range("A1")

End Sub

mais j'ai l'erreur "expecting object must be local"

A l'avance merci pour votre aide.

Bonjour

Il faut copier rng en valeur dans un tableau ne contenant qu'une ligne de titres

Hello

Pas bien compris ce que tu veux dire

RE

Rng c'est le TCD

Tu ne peux l'utiliser comme plage de l'autre feuille

A tester

Private Sub CommandButton1_Click()

Dim ws As Worksheet
Dim pvt As PivotTable
Dim rng As Range

With ThisWorkbook

    Set ws = .Worksheets("Filter")

    Set pvt = ws.PivotTables("PivotTable1")

    Set rng = IIf(pvt.RowGrand = False, pvt.TableRange1, pvt.TableRange1.Resize(pvt.TableRange1.Rows.Count - 1))
    rng.Copy
    With .Worksheets("Email")
        .Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "T_Mail"
        .ListObjects("T_Mail").TableStyle = "TableStyleLight13"
    End With
End With

End Sub

Top merci beaucoup, cela fonctionne nickel

Ce serait abuser de demander un dernier point?

Mon TCD n'a pas de repetition des items (plus simple à lire).

Est-il possible pour la création du tableau final, que celui-ci les ait? Histoire de ne pas avoir de blanc dans les différentes rows?

RE

Je pense plus simple de les activer temporairement dans le TCD (le temps de la copie) puis de rétablir la non répétition

OK je fais regarder cela et voir si je m'en sors.

Bonne soirée

@78chris:

Je viens de tester ce code mais j'ai une erreur "expecting object to be local" sur la ligne:

.ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "T_Mail"

Je ne connais pas ce code d'erreur...

Code:

Dim ws As Worksheet
Dim pvt As PivotTable
Dim rng As Range

Application.ScreenUpdating = False

With ThisWorkbook

    Set ws = .Worksheets("Filter")

    Set pvt = ws.PivotTables("PivotTable1")

    pvt.RepeatAllLabels (xlRepeatLabels)

    Set rng = IIf(pvt.RowGrand = False, pvt.TableRange1, pvt.TableRange1.Resize(pvt.TableRange1.Rows.Count - 1))
    rng.Copy

    With .Worksheets("Email")
        .Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "T_Mail"
        .ListObjects("T_Mail").TableStyle = "TableStyleLight13"
    End With

    pvt.RepeatAllLabels (xlDoNotRepeatLabels)
End With

Application.ScreenUpdating = True

Bonjour

Email est bien vide avant le lancement ? Sinon il faut ajouter une ligne en début de requête pour le faire

Bizarre car c'est la même erreur qu'avant...

Tu peux joindre une copie d'écran du TCD ?

Re

En effet, cela survient quand "Email" n'est pas vide....

Pour pallier à ce soucis, j'ai voulu mettre une ligne pour effacer le contenu de Email avant le chargement du tableau mais du coup j'ai un nouvelle erreur...

"PasteSpecial method of range class failed"

Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim pvt As PivotTable
Dim rng As Range

Application.ScreenUpdating = False

With ThisWorkbook

    Set ws = .Worksheets("Filter")

    Set pvt = ws.PivotTables("PivotTable1")

    pvt.RepeatAllLabels (xlRepeatLabels)

    Set rng = IIf(pvt.RowGrand = False, pvt.TableRange1, pvt.TableRange1.Resize(pvt.TableRange1.Rows.Count - 1))
    rng.Copy

    With .Worksheets("Email")
        .Cells.Clear
        .Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "T_Mail"
        .ListObjects("T_Mail").TableStyle = "TableStyleLight13"
    End With

    pvt.RepeatAllLabels (xlDoNotRepeatLabels)
End With

Application.ScreenUpdating = True

End Sub

RE

Ceci fonctionne chez moi

Private Sub CommandButton1_Click()

Dim ws As Worksheet
Dim pvt As PivotTable
Dim rng As Range

With ThisWorkbook
    .Worksheets("Email").Range("A1").CurrentRegion.Delete

    Set ws = .Worksheets("Filter")

    Set pvt = ws.PivotTables("PivotTable1")

    pvt.RepeatAllLabels (xlRepeatLabels)

    Set rng = IIf(pvt.RowGrand = False, pvt.TableRange1, pvt.TableRange1.Resize(pvt.TableRange1.Rows.Count - 1))
    rng.Copy
    With .Worksheets("Email")
        .Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "T_Mail"
        .ListObjects("T_Mail").TableStyle = "TableStyleLight13"
    End With

    pvt.RepeatAllLabels (xlDoNotRepeatLabels)

End With
    Application.CutCopyMode = False
End Sub

Top cela fonctionne nickel.

Un énorme merci pour ton aide

excellent week-end

De même

Bon j'ai encore un soucis...

Le code marche parfaitement sauf que comme le fichier est xlsm, je ne peux pas utiliser le tableau créé dans un flow power automate par exemple.

Du coup j'ai essayé de l'adapter pour enregistrer le tableau sur un fichier xlsx déjà existant (feuille: Sheet1).

Cela fonctionne bien mais s'il y a des chose déjà présente sur cette feuille, je n'arrive pas cleaner la feuille avant de faire la copie.

Si j'essaye de mettre un cells.clear sur son contenu avant de faire la copie, j'ai à nouveau l'erreur "pastespecial method...."

Voici mon code:

Option Explicit

Sub CreateEmailList()

    ' Constants
    Const swsName As String = "Filter"
    Const dFilePath As String = "https://xxxxxxxxxxxx/Shared%20Documents/Commercial/Informations%20Clients/_Gestion%20des%20Besoins%20QC/Liste%20emails.xlsx"
    Const dwsName As String = "Sheet1"
    Const dfCol As String = "A"

    ' Source
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim pvt As PivotTable
    Dim stbl As ListObject
    Dim rng As Range

    Set wb = ThisWorkbook

    With wb
        Set ws = wb.Worksheets(swsName)
        Set pvt = ws.PivotTables("PivotTable1")
        pvt.RepeatAllLabels (xlRepeatLabels)
        Set rng = IIf(pvt.RowGrand = False, pvt.TableRange1, pvt.TableRange1.Resize(pvt.TableRange1.Rows.Count - 1))
        rng.Copy
    End With

    Application.ScreenUpdating = False
    ' Destination
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim tbl As ListObject

    Set dwb = Workbooks.Open(dFilePath)
    Set dws = dwb.Worksheets(dwsName)
    With dws
        For Each tbl In .ListObjects
            tbl.Unlist
        Next
        .Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "T_Mail"
        .ListObjects("T_Mail").TableStyle = "TableStyleLight13"
    End With
    dwb.Close SaveChanges:=True

    pvt.RepeatAllLabels (xlDoNotRepeatLabels)
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

RE

Il faudrait que cela soit

.Range("A1").CurrentRegion.Delete

avant

.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Cependant vérifier si la copie est toujours disponible ou s'il faut déplacer

rng.Copy

entre les deux