The Daily Dose

Sub InstantPivot()

‘   InstantPivot: Just Add Water
‘   Assign this to Ctrl + Shift + P or something like that.

‘   Description:    * Turns selection into Excel ListObject
‘                   * Makes a Pivottable out of it at the edge of the used range
‘                   * Applies my preferred default settings
‘                   * Selects the Pivot and cuts it, so that
‘                     Dick Kusleika can then use arrow keys
‘                     and Control + V to paste it where he wants
‘                     without having to touch that unclean dusty rodent
‘                     he keeps at the edge of his Desk.Usedrange
‘

‘Here’s the settings it applies.
‘   1.  Changes the Report Layout to "Show in Tabular Form"
‘   2.  Turns on  "Repeat All Item Labels" option
‘   3.  Turn off Subtotals
‘   4.  Turn off Grand Totals
‘   5.  De-selects the Row Headers option from the Design tab.
‘   6.  Turns off ‘Autofit Column Width on Update’
‘   7.  Turns off ‘Save Source Data with file’ option.
‘   6.  Adopts the source formatting

‘   Programmer:     Jeff Weir
‘   Contact:        weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

‘   Name/Version:   Date:       Ini:   Modification:
‘   InstantPivot    20140213    JSW     Initial programming
‘   InstantPivotV2  20140216    JSW     Added error handler and check for multiple cells
‘   InstantPivotV3  20140216    JSW     Adopted SNB’s approach of setting numberformat while turning subtotals off
‘   InstantPivotV4  20140216    JSW     If run on existing pivot that is not based on ListObject, turns source into ListObject
‘   InstantPivotV5  20140216    JSW     Now ignores Values fields and doesn’t apply format if pf.function = xlCount

‘   Inputs:         None

‘   Outputs:        PivotTable is formatted accordingly

    Dim pc As PivotCache
    Dim pf As PivotField
    Dim pt As PivotTable
    Dim lo As ListObject
    Dim rng As Range
    Dim strLabel As String
    Dim strFormat As String
    Dim i As Long
    Dim wksSource As Worksheet

   
     ‘Check that we’re dealing with a version of Excel that supports ListObjects
   
   
    On Error Resume Next
    Set pt = ActiveCell.PivotTable
    On Error GoTo errhandler
    If pt Is Nothing Then
        Set lo = ActiveCell.ListObject
        If lo Is Nothing Then Set lo = ActiveSheet.ListObjects.Add(xlSrcRange, Selection.CurrentRegion, , xlYes)
        Set rng = Cells(ActiveSheet.UsedRange.Row, ActiveSheet.UsedRange.Columns.Count + ActiveSheet.UsedRange.Column + 1)
        Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=lo)
        Set pt = pc.CreatePivotTable(TableDestination:=rng)
    Else:
        ‘Check if pt is based on a ListObject.
        ‘  *  If so, set lo equal to that ListObject
        ‘  *  If not, turn that source data into a ListObject
        On Error Resume Next
        Set lo = Range(pt.SourceData).ListObject
        On Error GoTo errhandler
        If lo Is Nothing Then
            Set rng = Application.Evaluate(Application.ConvertFormula(pt.SourceData, xlR1C1, xlA1))
            Set wksSource = rng.Parent
            Set lo = wksSource.ListObjects.Add(xlSrcRange, rng, , xlYes)
            pt.ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=lo.Name)
        End If

    End If

    With pt
        .ColumnGrand = False
        .RowGrand = False
        .RowAxisLayout xlTabularRow
        .RepeatAllLabels xlRepeatLabels
        .ShowTableStyleRowHeaders = False
        .ShowDrillIndicators = False
        .HasAutoFormat = False
        .SaveData = False
        .ManualUpdate = True
        If ActiveCell.CurrentRegion.Cells.Count > 1 Then
            For i = 1 To .PivotFields.Count – .DataFields.Count ‘The .DataField.Count bit is just in case the pivot already exists
                Set pf = .PivotFields(i)
                With pf
                    If pf.Name <> "Values" Then
                        .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
                        On Error Resume Next
                        .NumberFormat = lo.DataBodyRange.Cells(1, i).NumberFormat
                        On Error GoTo errhandler
                    End If
                End With
            Next i
        End If
    End With
   
    ‘ Get DataFields to match the formatting of the source field
    ‘ Note that this will only be neccessariy in the case that we’re
    ‘ running this code on an existing pivot
    On Error GoTo errhandler
    If pt.DataFields.Count > 0 Then
        For Each pf In pt.DataFields
            If pf.Function <> xlCount Then pf.NumberFormat = pt.PivotFields(pf.SourceName).NumberFormat
            ‘ Do away with ‘Sum of’ or ‘Count of’ prefix etc if possible
            On Error Resume Next
            pf.Caption = pf.SourceName & " "
            On Error GoTo errhandler
        Next pf
    End If

    ‘This needs to go before the .Cut bit, otherwise the .Cut stack gets wiped
     With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlAutomatic
    End With
     
    With pt
        .ManualUpdate = False
        .TableRange2.Select
        .TableRange2.Cut
    End With
Err.Clear
errhandler:
        If Err.Number > 0 Then
            With Application
                .ScreenUpdating = True
                .EnableEvents = True
                .Calculation = xlAutomatic
            End With
            MsgBox "Whoops, there was an error: Error#" & Err.Number & vbCrLf & Err.Description _
                     , vbCritical, "Error", Err.HelpFile, Err.HelpContext
        End If