copy pivot table to new workbook/worksheet

Hi,

I'm struggling to copy a pivot table to a new workbook and worksheet. The code below creates the pivot table;

Sub Macro3()
'
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        "DATA!A1:R50000").CreatePivotTable TableDestination:="", TableName:= _
        "PivotTable2", DefaultVersion:=xlPivotTableVersion10
    ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
    ActiveSheet.Cells(3, 1).Select
    ActiveWorkbook.ShowPivotTableFieldList = True
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Proj")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Activity")
        .Orientation = xlRowField
        .Position = 2
    End With
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Week Comm")
        .Orientation = xlColumnField
        .Position = 1
    End With
    'With ActiveSheet.PivotTables("PivotTable2").PivotFields("Year")
    '    .Orientation = xlColumnField
    '    .Position = 1
    'End With
    ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables( _
        "PivotTable2").PivotFields("Quantity"), "Sum of Hours", xlSum
    ActiveWorkbook.ShowPivotTableFieldList = False
    ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables( _
        "PivotTable2").PivotFields("Amount"), "Sum of Mat Costs", xlSum
    ActiveWorkbook.ShowPivotTableFieldList = False
    ActiveSheet.Name = "pivot data sheet"
End Sub

but this code is failing once it gets past the creation of new workbook/worsheet stage;

Sub CreateBlankWorkbook()

Dim PT As PivotTable
Dim PTCache As PivotCache
Dim WSR As Worksheet
Dim WBN As Workbook

Set WBN = Workbooks.Add(xlWBATWorksheet)
Set WSR = WBN.Worksheets(1)
WSR.Name = "Report"
With WSR.[A1]
    .Value = "New Report"
    .Font.Size = 20
End With

ActiveSheet.PivotTables("PivotTable2").Copy
WSR.[A3].PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'PT.TableRange2.Clear
Set PTCache = Nothing

End Sub

Can anyone help please?

Thanks,

Louise

Hi,

Maybe you need to Select or Activate the sheet that has the pivot table on it? I'm looking at your code and it appears that it creates a new workbook, then adds "New Report" to cell A1 on worksheet(1), However once that is completed you are asking the script to copy from the "Activesheet"

ActiveSheet.PivotTables("PivotTable2").Copy

Just a thought, Mike

Hi Mike,

As you may have guessed I've pieced this code together from more than one source as I'm not that familiar with VBA yet.

Please would you suggest modified coding that I could try?

Thanks,

Louise

since macros can be recorded as well as written, your easiest answer might be to turn on the record...then select the top left of the pivot table (which should select it all)...copy and paste to new workook...the resulting macro could be incorporated into your code above?

add this to your code:

Dim ptRange As Range
    
'copy pivot table to new workbook - adjust worksheet name and pt name as required
Set ptRange = ThisWorkbook.Worksheets("Pivot").PivotTables("PivotTable1").TableRange2
ptRange.Copy
    
WSR.[A3].PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False