Hello,
I'm trying to modify the following vba in order to copy the pivot table that is selected by the user and paste it into a new book (not still opened), instead of into a new sheet in the same workbook.
Please check the attachment. Here is the VBA code inserted that I am not able to modify
Thanks in advance
regards
Mark
VBA CODE
Sub Paste_PT_with_Format()
Dim my_worksheet As Worksheet
Dim pivot_table As PivotTable
Dim pvt_tbl_rng As Range
Dim pvt_tbl_rngA As Range
Dim copy_rng As Range
Dim copy_rng2 As Range
Dim pt_top_row As Long
Dim pt_rows As Long
Dim pt_rows_page As Long
Dim message_spaces As String
On Error Resume Next
Set pivot_table = ActiveCell.PivotTable
Set pvt_tbl_rngA = pivot_table.PageRange
On Error GoTo errHandler
If pivot_table Is Nothing Then
MsgBox "Excel Can't Copy PivotTable"
GoTo exitHandler
End If
If pivot_table.PageFieldOrder = xlOverThenDown Then
If pivot_table.PageFields.Count > 1 Then
message_spaces = "Spaces with filters." _
& vbCrLf _
& "Can't copy filters."
End If
End If
Set pvt_tbl_rng = pivot_table.TableRange1
pt_top_row = pvt_tbl_rng.Rows(1).Row
pt_rows = pvt_tbl_rng.Rows.Count
Set my_worksheet = Worksheets.Add
Set copy_rng = pvt_tbl_rng.Resize(pt_rows - 1)
Set copy_rng2 = pvt_tbl_rng.Rows(pt_rows)
copy_rng.Copy Destination:=my_worksheet.Cells(pt_top_row, 1)
copy_rng2.Copy _
Destination:=my_worksheet.Cells(pt_top_row + pt_rows - 1, 1)
If Not pvt_tbl_rngA Is Nothing Then
pt_rows_page = pvt_tbl_rngA.Rows(1).Row
pvt_tbl_rngA.Copy Destination:=my_worksheet.Cells(pt_rows_page, 1)
End If
my_worksheet.Columns.AutoFit
If message_spaces <> "" Then
MsgBox message_spaces
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Excel Can't Copy PivotTable"
Resume exitHandler
End Sub
Hello,
To whom is interested, this is the solution..
Mark
Sub Paste_PT_with_Format()
Dim wkb As Workbook
Dim message_spaces As String
Dim my_worksheet As Worksheet
Dim pivot_table As PivotTable
Dim pvt_tbl_rng As Range, pvt_tbl_rngA As Range, copy_rng As Range, copy_rng2 As Range
Dim pt_top_row As Long, pt_rows As Long, pt_rows_page As Long
On Error Resume Next
Set pivot_table = ActiveCell.PivotTable
Set pvt_tbl_rngA = pivot_table.PageRange
On Error GoTo errHandler
If pivot_table Is Nothing Then
MsgBox "Excel Can't Copy PivotTable"
GoTo exitHandler
End If
If pivot_table.PageFieldOrder = xlOverThenDown Then
If pivot_table.PageFields.Count > 1 Then
message_spaces = "Spaces with filters." _
& vbCrLf _
& "Can't copy filters."
End If
End If
Set pvt_tbl_rng = pivot_table.TableRange1
pt_top_row = pvt_tbl_rng.Rows(1).Row
pt_rows = pvt_tbl_rng.Rows.Count
'---------------------------------------------------------------------
'this is the bit that's creating a worksheet in the existing workbook:
'Set my_worksheet = Worksheets.Add
'---------------------------------------------------------------------
'use this instead:
'-----------------
Application.Workbooks.Add
Set wkb = ActiveWorkbook 'so you can reference it later to save/close.
Set my_worksheet = wkb.Sheets(1)
Set copy_rng = pvt_tbl_rng.Resize(pt_rows - 1)
Set copy_rng2 = pvt_tbl_rng.Rows(pt_rows)
copy_rng.Copy Destination:=my_worksheet.Cells(pt_top_row, 1)
copy_rng2.Copy Destination:=my_worksheet.Cells(pt_top_row + pt_rows - 1, 1)
If Not pvt_tbl_rngA Is Nothing Then
pt_rows_page = pvt_tbl_rngA.Rows(1).Row
pvt_tbl_rngA.Copy Destination:=my_worksheet.Cells(pt_rows_page, 1)
End If
my_worksheet.Columns.AutoFit
If message_spaces <> "" Then MsgBox message_spaces
exitHandler:
Exit Sub
errHandler:
MsgBox "Excel Can't Copy PivotTable"
Resume exitHandler
End Sub
