Log In
Register
Home
March 17, 2020
Offline
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
See AnswerMarch 17, 2020
Offline
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
Answers Post
1 Guest(s)
