Little Big Pivot: a pivot compressor

Back!

Short version:
Creates a lighter copy of the pivot table, removing unwanted fields an values.
So you can share a real pivot table, as you designed it, instead of a useless copy of pivot table.
Lighter (email friendly), cleaner, more performance, no confidentiality issues as unwanted data are not embedded in the new pivot table.

The before & after picture:

The idea is to "slim" a pivot: 
The macro aggregates the values used in the pivot table as a new source for the new pivot table.

• The new pivot table is an exact copy: same formatting, same custom names, same value formats
• Only visible fields ( including page fields on top of pivot) are kept
• Filtered values won't be available in the new pivot
• You can use the unique count macro with this new pivot, it should be a lot faster  and resolves the issues of grouped fields in the      http://lazyvba.blogspot.co.uk/2010/11/improve-your-pivot-table-to-count.html

Instructions:

• Work on a copy of your document, of course
• Paste the code in any module
• Prepare your table: Move unwanted fields into the "Pivot Fields List"
• Set up your filters
• Run the code: two new sheets are created, one with the new pivot, one named "lightdata" with the new aggregated source.

My comments:

• Tested briefly on various versions of Excel: 2003, 2007, 2010, feedback welcome.
• Grouped and renamed fields are managed
• It only works if your data fields are sums! (no average, min, max or other calculations)
• Previous pivot tables and sources are still in the workbooks: delete them if your satisfied with the result.
• Bug with remote connection to solve

Example can be downloaded here, dummy data (20,000 rows generated via fakenamegenerator.com ).
Code already run, so you can see the result.
A security warning could appear according to your settings: it's still a file with macro downloaded from internet.

Let now know your thoughts, or suggestions to improve our pivot tables, in the comments.



Sub LittleBigPivot()
'by lazyvba.blogspot.com

Dim vArr, arraypos As Variant
Dim pfc, r, c, gt, c2 As Integer
Dim tem As String
Dim datarng, newdata As Range

Dim wb As Workbook, wp, wp2, newdatasheet As Worksheet, _
pt, pt2 As PivotTable, pf, cf, rf As PivotField


Set wb = ActiveWorkbook
Set wp = ActiveSheet
Set pt = wp.PivotTables(1)

Err.Clear
On Error Resume Next
wp.Copy after:=wp
Set wp2 = ActiveSheet
Set pt2 = wp2.PivotTables(1)
pfc = pt2.PivotFields.Count
r = 1
ReDim arraypos(1 To 4, 1 To 1)
For Each pf In pt2.PivotFields
If pf.Orientation <> xlHidden Then

If Err.Number <> 0 Then
GoTo suite
End If
arraypos(4, r) = pf.ChildField.Name
arraypos(1, r) = pf.Name
arraypos(2, r) = pf.Orientation
arraypos(3, r) = pf.Position
ReDim Preserve arraypos(1 To 4, 1 To UBound(arraypos, 2) + 1)
r = r + 1
End If
suite:
Err.Clear
Next

On Error GoTo 0

pt2.ManualUpdate = True
For Each pf In pt2.PageFields
pt2.PivotFields(pf.Name).Orientation = xlRowField
Next
For Each cf In pt2.ColumnFields
pt2.PivotFields(cf.Name).Orientation = xlRowField
Next
On Error Resume Next
pt2.DataPivotField.Orientation = xlColumnField
With pt2
    .RowAxisLayout xlTabularRow
    .InGridDropZones = True
    .DisplayContextTooltips = False
End With
On Error GoTo 0

For Each rf In pt2.RowFields
pt2.PivotFields(rf.Name).Subtotals(1) = True
pt2.PivotFields(rf.Name).Subtotals(1) = False
Next

pt2.ManualUpdate = False

For c = 1 To pt2.RowRange.Columns.Count - 1

pt2.RowRange.Columns(c).Offset(1, 0).Resize(pt2.RowRange.Rows.Count - 1, 1).Select
Selection.ShowDetail = True
Next

If pt2.RowRange.Cells(pt2.RowRange.Rows.Count, 1).Value = "Grand Total" Then
gt = 1
Else
gt = 0
End If


Set datarng = Range(pt2.RowRange.Cells(1, 1), pt2.DataBodyRange. _
Cells(pt2.DataBodyRange.Rows.Count - gt, pt2.DataBodyRange.Columns.Count))
vArr = datarng.Value


For c = 1 To pt2.RowRange.Columns.Count
For r = 2 To datarng.Rows.Count
If IsEmpty(vArr(r, c)) Then
vArr(r, c) = vArr(r - 1, c)
End If
Next
Next

If pt2.DataFields.Count = 1 Then
vArr(1, datarng.Columns.Count) = pt2.DataFields(1).SourceName
Else
For c2 = 1 To datarng.Columns.Count
vArr(1, c2) = pt2.PivotFields(vArr(1, c2)).SourceName
Next
End If

c2 = datarng.Columns.Count

Application.DisplayAlerts = False
wp2.Delete
Application.DisplayAlerts = True

Worksheets.Add
Set newdata = Range(Cells(1, 1), Cells(r - 1, c2))
Set newdatasheet = ActiveSheet
newdata.Value = vArr
ActiveSheet.Name = "lightdata"

wp.Copy after:=wp
Set wp2 = ActiveSheet
Set pt2 = wp2.PivotTables(1)
pt2.ManualUpdate = False


pt2.SourceData = "lightdata!" & newdata.Address(ReferenceStyle:=xlR1C1)
pt2.RefreshTable
If UBound(arraypos, 2) > 1 Then
For r = 1 To UBound(arraypos, 2) - 1
pt2.PivotFields(arraypos(1, r)).Orientation = arraypos(2, r)
pt2.PivotFields(arraypos(1, r)).Position = arraypos(3, r)
Next
End If
pt2.ManualUpdate = True

End Sub