From the excellent blog: http://xkcd.com

Friday, 17 August 2012

Little Big Pivot: a pivot compressor


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
  • 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)

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

On Error GoTo 0

pt2.ManualUpdate = True
For Each pf In pt2.PageFields
pt2.PivotFields(pf.Name).Orientation = xlRowField
For Each cf In pt2.ColumnFields
pt2.PivotFields(cf.Name).Orientation = xlRowField
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

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

If pt2.RowRange.Cells(pt2.RowRange.Rows.Count, 1).Value = "Grand Total" Then
gt = 1
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

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

c2 = datarng.Columns.Count

Application.DisplayAlerts = False
Application.DisplayAlerts = True

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)
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)
End If
pt2.ManualUpdate = True

End Sub

No comments:

Post a Comment