Macro to copy values only from multiple sheets containing pivot tables to new workbook maintaining pivot table formatting

rach9915

New Member
Joined
Dec 5, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hi,

I'm currently using version 365.

I need a macro to perform the following functions in a workbook containing multiple sheets

- Copy 2 of the sheets containing pivot tables (as well as other data) to a new workbook as values
- Maintain all formatting including pivot table formatting into the new workbook and column widths
- Name the new sheets the same as the existing sheet names
- Delete 'sheet 1' in the new workbook
- Save the new workbook to the same location where existing file is located, with new workbook name specified in the code
- Open file on saving

I have modified the below which I found on an excel forum however the formatting is not copying across for the pivot tables, only for the other data. I am having trouble modifying it to copy the pivot table formatting.

Sub CopyPivotValues()

Dim sWB As Workbook
Dim dWB As Workbook
Dim MySheets, i As Long, ws As Worksheet, Rng As Range

MySheets = Array("DATA", "Rach")

Set sWB = ThisWorkbook
Set dWB = Workbooks.Add

Const NewwbName As String = "Production Report"
With Application
.ScreenUpdating = 0
.DisplayAlerts = 0
End With
For i = 0 To UBound(MySheets)
On Error Resume Next
Set ws = dWB.Sheets(MySheets(i))
On Error GoTo 0
With sWB.Sheets(MySheets(i))
Set Rng = .Range("a1", .Range("a1").SpecialCells(xlCellTypeLastCell))
Rng.UnMerge
End With
With dWB
If ws Is Nothing Then
Set ws = Sheets.Add
ws.Name = MySheets(i)
End If
Rng.Copy
ws.Range("a1").PasteSpecial xlPasteValues
ws.Range("a1").PasteSpecial xlPasteFormats
ws.Range("a1").PasteSpecial xlPasteColumnWidths
Set ws = Nothing
Set Rng = Nothing

ActiveWindow.DisplayGridlines = False

End With
Next
dWB.SaveAs Replace(sWB.FullName, sWB.Name, NewwbName & ".xlsm"), 52
dWB.Close False
With Application
.ScreenUpdating = 1
.DisplayAlerts = 1
End With
End Sub

Thank you!
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

Alex Blakenburg

MrExcel MVP
Joined
Feb 23, 2021
Messages
5,005
Office Version
  1. 365
Platform
  1. Windows
See if this works for you.

Before this line in your code:- Set ws = Nothing

Add this line: Call PivotCopyFormatValues(sWS:=sWB.Sheets(MySheets(i)), dWB:=dWB)

The add this sub in the same module:-
(based on code from Debra Dalgleish Contextures -> Excel Pivot Table Macro Paste Format Values

VBA Code:
Private Sub PivotCopyFormatValues(sWS As Worksheet, dWB As Workbook)

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 lColLeft As Long
Dim lRowsPT As Long
Dim lRowPage As Long

Dim wb As Workbook
Dim outWB As Workbook

Set wb = ThisWorkbook
Set outWB = dWB

'  Pivot Loop

'
    For Each pt In sWS.PivotTables
        On Error Resume Next
            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
                lColLeft = rngPT.Columns(1).Column
                Set rngCopy = rngPT.Resize(lRowsPT - 1)
                Set rngCopy2 = rngPT.Rows(lRowsPT)
                
                rngCopy.Copy Destination:=outWB.Worksheets(sWS.Name).Cells(lRowTop, lColLeft)
                rngCopy2.Copy Destination:=outWB.Worksheets(sWS.Name).Cells(lRowTop + lRowsPT - 1, lColLeft)
            End If
            
            If Not rngPTa Is Nothing Then
                lRowPage = rngPTa.Rows(1).Row
                rngPTa.Copy Destination:=outWB.Worksheets(sWS.Name).Cells(lRowPage, lColLeft)
            End If

            outWB.Worksheets(sWS.Name).Columns.AutoFit
        Next pt


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

rach9915

New Member
Joined
Dec 5, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Thank you so much for your response that worked perfectly, it copied the data as values and then copied the pivot table formatting. I have come across an issue however. Copying the pivot table formatting is making the file size huge, a file with 4 tabs each with a maximum of 50 rows of data is coming out at 50MB in size. When I remove the formatting and save as it is the file size shrinks to almost nothing.

I changed the pivot formatting to the most basic format with just column borders and the font the same all the way through however that didn't help at all. Would you have any idea of a solution?

Thanks again!
 

Alex Blakenburg

MrExcel MVP
Joined
Feb 23, 2021
Messages
5,005
Office Version
  1. 365
Platform
  1. Windows
That seems odd if the pivot really copied values.
Can you click inside a few of the tables and just make sure that the show PivotTable Fields options don't appear.
Can you click on Power Pivot > Manage and make sure there is nothing in the data model.

Next just check the sheets with pivots and see where Ctrl + End takes you.
 

Forum statistics

Threads
1,175,524
Messages
5,897,920
Members
434,687
Latest member
alybazaza

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top