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

[rach9915]

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!

 

[Alex Blakenburg]

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

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]

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]

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.