Copy paste Pivot table with formats

[Pratsexcel]

Hello all,

Need your help in copy pasting pivot table with formats " without drop downs"

Please refer attached excel sheet wherein i have demonstrated how the pivot table I need to paste on the same sheet.

I found this macro on one of excel sites & also in forums. but this code copy pastes the pivot table on new worksheet I need to paste it on same worksheet. can you please help

Sub PivotCopyFormatValues()
Dim ws As Worksheet
Dim pt As PivotTable
Dim rngPT As Range
Dim rngPTa As Range
Dim rngCopy As Range
Dim rngCopy2 As Range
Dim lRowTop As Long
Dim lRowsPT As Long
Dim lRowPage As Long

On Error Resume Next
Range("A1").Select
Set pt = ActiveCell.PivotTable
Set rngPTa = pt.PageRange
On Error GoTo errHandler

If pt Is Nothing Then
    MsgBox "Could not copy pivot table for active cell"
    GoTo exitHandler
Else
    Set rngPT = pt.TableRange1
    lRowTop = rngPT.Rows(1).Row
    lRowsPT = rngPT.Rows.Count
    Set ws = Worksheets.Add
    Set rngCopy = rngPT.Resize(lRowsPT - 1)
    Set rngCopy2 = rngPT.Rows(lRowsPT)
   
    rngCopy.Copy Destination:=ws.Cells(lRowTop, 1)
    rngCopy2.Copy Destination:=ws.Cells(lRowTop + lRowsPT - 1, 1)
End If

If Not rngPTa Is Nothing Then
    lRowPage = rngPTa.Rows(1).Row
    rngPTa.Copy Destination:=ws.Cells(lRowPage, 1)
End If
   
ws.Columns.AutoFit

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not copy pivot table for active cell"
    Resume exitHandler
End Sub


Thanks a lot in Advance

 

[Nebu]

Hi:

You have to get rid of the line
Set ws = Worksheets.Add
This line is to add a new work sheet.

In the below code lines

rngCopy.Copy Destination:=ws.Cells(lRowTop, 1)
rngCopy2.Copy Destination:=ws.Cells(lRowTop + lRowsPT - 1, 1)

The destination has to be changed to

rngCopy.Copy Destination:=Your sheetname.your desired range
rngCopy2.Copy Destination:=Your sheetname.your desired range

Thanks

 

[Pratsexcel]

Hi Nebu,

Firstly Thanks A ton for your suggestion it is solving my problem very well with a just a small issue.

i.e. whenever I try to run the macro with suggested changes it gives me an error message that

"Could not copy pivot table for active cell"

and on destination cell only the table is pasted and not the heading That is description part

Can you please help ?

Thanks in advance

Sub Pivo_copy_paste()

Dim ws As Worksheet
Dim pt As PivotTable
Dim rngPT As Range
Dim rngPTa As Range
Dim rngCopy As Range
Dim rngCopy2 As Range
Dim lRowTop As Long
Dim lRowsPT As Long
Dim lRowPage As Long

On Error Resume Next
Range("A1").Select
Set pt = ActiveCell.PivotTable
Set rngPTa = pt.PageRange
On Error GoTo errHandler

If pt Is Nothing Then
    MsgBox "Could not copy pivot table for active cell"
    GoTo exitHandler
Else
    Set rngPT = pt.TableRange1
    lRowTop = rngPT.Rows(1).Row
    lRowsPT = rngPT.Rows.Count
   
    Set rngCopy = rngPT.Resize(lRowsPT - 1)
    Set rngCopy2 = rngPT.Rows(lRowsPT)
   
    rngCopy.Copy Destination:=ActiveSheet.Cells(lRowTop, 14)
    rngCopy2.Copy Destination:=ActiveSheet.Cells(lRowTop + lRowsPT - 1, 14)
End If

If Not rngPTa Is Nothing Then
    lRowPage = rngPTa.Rows(1).Row
    rngPTa.Copy Destination:=ws.Cells(lRowPage, 1)
End If
   
ws.Columns.AutoFit

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not copy pivot table for active cell"
    Resume exitHandler

End Sub

 

[Nebu]

Hi:

Use the following code:

Sub Pivo_copy_paste()

Dim pt As PivotTable
Dim rngPT As Range
Dim rngPTa As Range
Dim rngCopy As Range
Dim rngCopy2 As Range
Dim lRowTop As Long
Dim lRowsPT As Long
Dim lRowPage As Long

On Error Resume Next
Range("A1").Select
Set pt = ActiveCell.PivotTable
Set rngPTa = pt.PageRange
On Error GoTo errHandler

If pt Is Nothing Then
    MsgBox "Could not copy pivot table for active cell"
    GoTo exitHandler
Else
    Set rngPT = pt.TableRange1
    lRowTop = rngPT.Rows(1).Row
    lRowsPT = rngPT.Rows.Count
 
    Set rngCopy = rngPT.Resize(lRowsPT - 1)
    Set rngCopy2 = rngPT.Rows(lRowsPT)
 
    rngCopy.Copy Destination:=ActiveSheet.Cells(lRowTop, 14)
    rngCopy2.Copy Destination:=ActiveSheet.Cells(lRowTop + lRowsPT - 1, 14)
End If

If Not rngPTa Is Nothing Then
    lRowPage = rngPTa.Rows(1).Row
    rngPTa.Copy Destination:=ActiveSheet.Cells(lRowPage, 14)
End If
 
ActiveSheet.Columns.AutoFit

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not copy pivot table for active cell"
    Resume exitHandler

End Sub

Thanks

 

[Pratsexcel]

Hi Nebu,

Worked perfectly,

Thanks a ton for your support.