CODEWITHSUNDEEP
vbaexcelpivotpivot-table
Sorath
Sorath

Reputation: 553

Changing all Pivot Tables to just values

I am using the following code in order to export a macro enabled report to an .xls file with only certain worksheets from the original workbook.

Sub exportFile()
Dim sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
dates = Format(Now, "dd-mm-yyyy")
CurrentWorkbookName = ActiveWorkbook.Name
NewWorkbookName = "Friday Commentary " & dates & ".xlsx"
filePath = ActiveWorkbook.Path


Set NewBook = Workbooks.Add
    With NewBook
        .Title = "All Sales"
        .Subject = "Sales"
        .SaveAs Filename:=filePath & "\" & NewWorkbookName  ', FileFormat:=50  '50 = xlExcel12 (Excel Binary Workbook in 2007-2013 with or without macro's, xlsb)
    End With


Workbooks(CurrentWorkbookName).Activate
For Each sh In Worksheets

If sh.Name = "1" Or sh.Name = "2" Or sh.Name = "3" Or sh.Name = "4" Or sh.Name = "5" Or sh.Name = "6" Or sh.Name = "EXPORT" Or sh.Name = "RAW" Then
   Workbooks(CurrentWorkbookName).Sheets(sh.Name).Copy After:=Workbooks(NewWorkbookName).Sheets(Workbooks(NewWorkbookName).Sheets.Count)
   Workbooks(CurrentWorkbookName).Activate
End If

Next


End Sub

Each sheet from 1 - 6 has a pivot table from the same data source. I want these pivot tables to be only extracted as values (not a pivot table) with the pivot table formatting, of course. How do I include this in my macro?

Upvotes: 1

Views: 2129

Answers (2)

Subodh Tiwari sktneer
Subodh Tiwari sktneer

Reputation: 9976

You may tweak your code like this...

Sub exportFile()
Dim NewBook As Workbook, swb As Workbook
Dim ws As Worksheet
Dim dates As String, filePath As String, CurrentWorkbookName As String, NewWorkbookName As String
Dim shNames, sh
Dim pt As PivotTable
Dim x
Dim cellAddress As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set swb = ActiveWorkbook
dates = Format(Now, "dd-mm-yyyy")
CurrentWorkbookName = swb.Name
NewWorkbookName = "Friday Commentary " & dates & ".xlsx"
filePath = swb.Path

shNames = Array(1, 2, 3, 4, 5, 6, "EXPORT", "RAW")
swb.Sheets(1).Select
For Each sh In shNames
    swb.Sheets(sh).Select False
Next sh

ActiveWindow.SelectedSheets.Copy
Set NewBook = ActiveWorkbook

For Each ws In NewBook.Sheets
    On Error Resume Next
    Set pt = ws.PivotTables(1)
    On Error GoTo 0
    If Not pt Is Nothing Then
        cellAddress = pt.TableRange2.Cells(1).Address
        x = pt.TableRange2.Value
        pt.TableRange2.Delete
        ws.Range(cellAddress).Resize(UBound(x, 1), UBound(x, 2)).Value = x
    End If
    Set pt = Nothing
Next ws    

NewBook.SaveAs Filename:=filePath & "\" & NewWorkbookName

swb.Activate
swb.Sheets(1).Select
End Sub

Upvotes: 0

Vityata
Vityata

Reputation: 43585

If you have multiple PivotTables in a worksheet, they are present in the collection PivotTables. Thus, you can access them easily and modify their properties.

Option Explicit

Public Sub TestMe()

    Dim pt As PivotTable

    For Each pt In Worksheets(1).PivotTables
        pt.RefreshTable
        pt.TableRange2.Copy
        pt.TableRange2.PasteSpecial Paste:=xlPasteValues
    Next pt

    Application.CutCopyMode = False

End Sub

In your case, loop through every worksheet and there loop through every PivotTable in the worksheet, copying and pasting its TableRange2:

TableRange2 returns a Range object that represents the range containing the entire PivotTable report, including page fields. Read-only.

Upvotes: 1

Related Questions