Inversely filter a Pivot based on an external range

Posted on December 3, 2013March 17, 2018 by Jeff Weir

Howdy folks. Jeff here, with a money-saving Christmas tip. Oh, and some PivotTable code.

I recently posted a routine to filter pivots based on an external range. My code worked out whether it was fastest to either:

Hide all items in the field, then unhide those Pivot Items that matched the search terms; or
Unhide all items in the field, then hide those Pivot Items that don’t match the search terms.

It worked out what to hide or leave by adding the Search Terms to a Dictionary, then trying to add the Pivot Items and catching any errors. In that first case where it unhides Pivot Items that match the search terms, here’s the code that did the dictionary check on the PivotItems – after the Search Terms had already been added:

With dic
    For Each pi In pfOriginal.PivotItems
        dic.Add pi.Value, 1 'The 1 does nothing
        If Err.Number <> 0  Then
            'This item exists in our search term list, so we should unhide it
            'Note that IF this item is a date but the PivotField format is NOT a date format,
            ' we can't programatically hide/show items, so we'll have to check this first
            If Not bDateFormat Then
                If Not IsNumeric(pi.Value) Then
                    'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates
                    If IsDate(pi.Value) Then
                        If Not bDateWarning Then
                            On Error GoTo ErrHandler
                            Err.Raise Number:=997, Description:="Can't filter dates"
                            On Error Resume Next
                        End If
                    Else: pi.Visible = True
                    End If
                Else: pi.Visible = True
                End If
            Else: pi.Visible = True
            End If
        End If
        Err.Clear
    Next
End With

&nbsp;
<a href="http://dailydoseofexcel.com/archives/2013/11/05/excel-isnt-fully-cooked/#comment-96559">Pete</a> commented <em>Another user might want to filter to exclude records listed in an external range</em>. Damn users. Bane of my life. Ah well...I thought I'd have a crack at rewriting the routine to do such exclusions. I was really surprised by how easy it was.

For implementing an inverse filter, I added an optional bInverse argument to the function, with a default value of False. In the case that the function is called with that argument being TRUE, I need the revised code to dynamically change this line:
If Err.Number <> 0 Then
...to this:
If Err.Number = 0 Then
Using an <strong>If</strong> or <strong>Select Case</strong> construct is one way you could do this:

With dic
    For Each pi In pfOriginal.PivotItems
        dic.Add pi.Value, 1 'The 1 does nothing
        If bInverse Then
            If Err.Number <> 0 Then
                'This item exists in our search term list, so we should unhide it
                'Note that IF this item is a date but the PivotField format is NOT a date format,
                ' we can't programatically hide/show items, so we'll have to check this first
                If Not bDateFormat Then
                    If Not IsNumeric(pi.Value) Then
                        'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates
                        If IsDate(pi.Value) Then
                            If Not bDateWarning Then
                                On Error GoTo ErrHandler
                                Err.Raise Number:=997, Description:="Can't filter dates"
                                On Error Resume Next
                            End If
                        Else: pi.Visible = True
                        End If
                    Else: pi.Visible = True
                    End If
                Else: pi.Visible = True
                End If
            End If
        Else:
            If Err.Number = 0 Then
                'This item exists in our search term list, so we should unhide it
                'Note that IF this item is a date but the PivotField format is NOT a date format,
                ' we can't programatically hide/show items, so we'll have to check this first
                If Not bDateFormat Then
                    If Not IsNumeric(pi.Value) Then
                        'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates
                        If IsDate(pi.Value) Then
                            If Not bDateWarning Then
                                On Error GoTo ErrHandler
                                Err.Raise Number:=997, Description:="Can't filter dates"
                                On Error Resume Next
                            End If
                        Else: pi.Visible = True
                        End If
                    Else: pi.Visible = True
                    End If
                Else: pi.Visible = True
                End If
            End If
        End If
        Err.Clear
    Next
End With

With dic

For Each pi In pfOriginal.PivotItems

dic.Add pi.Value, 1 'The 1 does nothing

If Err.Number <> 0 Then

'This item exists in our search term list, so we should unhide it

'Note that IF this item is a date but the PivotField format is NOT a date format,

' we can't programatically hide/show items, so we'll have to check this first

If Not bDateFormat Then

If Not IsNumeric(pi.Value) Then

'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates

If IsDate(pi.Value) Then

If Not bDateWarning Then

On Error GoTo ErrHandler

Err.Raise Number:=997, Description:="Can't filter dates"

On Error Resume Next

End If

Else: pi.Visible = True

End If

Else: pi.Visible = True

End If

Else: pi.Visible = True

End If

Err.Clear

End With

<a href="http://dailydoseofexcel.com/archives/2013/11/05/excel-isnt-fully-cooked/#comment-96559">Pete</a> commented <em>Another user might want to filter to exclude records listed in an external range</em>. Damn users. Bane of my life. Ah well...I thought I'd have a crack at rewriting the routine to do such exclusions. I was really surprised by how easy it was.

For implementing an inverse filter, I added an optional bInverse argument to the function, with a default value of False. In the case that the function is called with that argument being TRUE, I need the revised code to dynamically change this line:

If Err.Number <> 0 Then

...to this:

If Err.Number = 0 Then

Using an <strong>If</strong> or <strong>Select Case</strong> construct is one way you could do this:

With dic

For Each pi In pfOriginal.PivotItems

dic.Add pi.Value, 1 'The 1 does nothing

If bInverse Then

If Err.Number <> 0 Then

'This item exists in our search term list, so we should unhide it

'Note that IF this item is a date but the PivotField format is NOT a date format,

' we can't programatically hide/show items, so we'll have to check this first

If Not bDateFormat Then

If Not IsNumeric(pi.Value) Then

'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates

If IsDate(pi.Value) Then

If Not bDateWarning Then

On Error GoTo ErrHandler

Err.Raise Number:=997, Description:="Can't filter dates"

On Error Resume Next

End If

Else: pi.Visible = True

End If

Else: pi.Visible = True

End If

Else: pi.Visible = True

End If

Else:

If Err.Number = 0 Then

'This item exists in our search term list, so we should unhide it

'Note that IF this item is a date but the PivotField format is NOT a date format,

' we can't programatically hide/show items, so we'll have to check this first

If Not bDateFormat Then

If Not IsNumeric(pi.Value) Then

'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates

If IsDate(pi.Value) Then

If Not bDateWarning Then

On Error GoTo ErrHandler

Err.Raise Number:=997, Description:="Can't filter dates"

On Error Resume Next

End If

Else: pi.Visible = True

End If

Else: pi.Visible = True

End If

Else: pi.Visible = True

End If

Err.Clear

End With

…but that seems like overkill, because the only line we want to conditionally change is that If Err.Number <> 0 Then line. The rest of the block is just fine the way it is.

So how to conditionally change just that one line? Like this:

If Err.Number <> 0 = Not bInverse Then

1	If Err.Number <> 0 = Not bInverse Then

Boy, that was simple. Adding the 2nd logical effectively flips the If Err.Number <> 0 bit to If Err.Number = 0 in the case that bInverse is TRUE.

It works a treat: I tested it on a Pivot containing the things I’m willing to buy the kids for Christmas, and an external list of things containing the presents that the kids actually want. Suffice to say I set bInverse to TRUE, and saved myself a small fortune in a few milliseconds.

And there’s your Christmas tip. Ho ho horrible, I know.

Here’s the whole amended routine:

Option Explicit

Sub FilterPivot()
'   Description:    Wrapper function for my FilterPivot Function
'                   (Required in the event that a user wants to trigger the FilterPivot
'                   function and specify parameters at runtime, instead of programatiacally
'                   calling the routine)
'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

'   Name/Version:   Date:       Ini:   Modification:
'   FilterPivot     20150305    JSW    Initial programming

FilterPivot_Routine
End Sub

Sub FilterPivot_Invert()
'   Description:    Wrapper function for my FilterPivot_Inverse Function
'                    Inverts the current selection
'                   (Required in the event that a user wants to trigger the FilterPivot_Inverse
'                   function and specify parameters at runtime, instead of programatiacally
'                   calling the routine)
'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

'   Name/Version:       Date:       Ini:   Modification:
'   FilterPivot_Inverse 20150305    JSW    Initial programming
FilterPivot_Routine ActiveCell.PivotField.DataRange, ActiveCell.PivotField.DataRange, bInverse:=True
End Sub


Sub FilterPivot_Inverse()
'   Description:    Wrapper function for my FilterPivot_Inverse Function
'                   (Required in the event that a user wants to trigger the FilterPivot_Inverse
'                   function and specify parameters at runtime, instead of programatiacally
'                   calling the routine)
'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

'   Name/Version:       Date:       Ini:   Modification:
'   FilterPivot_Inverse 20150305    JSW    Initial programming
FilterPivot_Routine bInverse:=True
End Sub


Private Sub FilterPivot_AddRightClick()
   
'   Description:    Adds  "Filter Pivotfield" shortcuts to PivotTable right-click menu
'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

'   Name/Version:   Date:       Ini:   Modification:
'   AddShortcuts    20150305    JSW    Initial programming

    Dim cbr As CommandBar
    Dim sMessage As String

    Set cbr = Application.CommandBars("PivotTable Context Menu")

    With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)
        .Caption = "Filter Pivotfield"
        .Tag = "FilterPivotField"
        .OnAction = "FilterPivot"
        .Style = msoButtonIconAndCaption
        .Picture = Application.CommandBars.GetImageMso("FilterAdvancedByForm", 16, 16)
    End With
    With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)
        .Caption = "Inversely Filter Pivotfield"
        .Tag = "FilterPivotField"
        .OnAction = "FilterPivot_Inverse"
        .Style = msoButtonIconAndCaption
        .Picture = Application.CommandBars.GetImageMso("FilterAdvancedMenu", 16, 16)
    End With

    sMessage = "Cool, I've added an option for you to trigger this code by right-clicking "
    sMessage = sMessage & "the PivotTable field that you want to filter."
    sMessage = sMessage & vbNewLine & vbNewLine & "Happy filtering!"
    
    MsgBox sMessage, vbOKOnly, "Right-click options added..."
    
End Sub

Private Sub FilterPivot_RemoveRightClick()
   
'   Description:    Removes  "Filter Pivotfield" shortcuts from PivotTable right-click menu
'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

'   Name/Version:   Date:       Ini:   Modification:
'   AddShortcuts    20150305    JSW    Initial programming

    Dim cbr As CommandBar
    Dim sMessage As String
    Dim ctrl As CommandBarControl
    
    
    Set cbr = Application.CommandBars("PivotTable Context Menu")
    For Each ctrl In cbr.Controls
        If ctrl.Tag = "FilterPivotField" Then ctrl.Delete
    Next
    

    sMessage = "Cool, I've removed the RightClick options for the FilterPivot routines."
    MsgBox sMessage, vbOKOnly, "Right-click options added..."

    
End Sub


Private Function FilterPivot_Slicers(ptTemp As PivotTable, pfTemp As PivotField, ptOriginal As PivotTable)
Dim sc As SlicerCache
' This sub-function contains code that requires Slicers
' It's in this stand-alone function, becaues it only gets called if user has Excel 2010 or later
' If it was incorporated DIRECTY within the FilterPivot function, that function wouldn't compile on pre 2010 machines

    Set sc = ActiveWorkbook.SlicerCaches.Add(ptTemp, pfTemp)
    sc.PivotTables.AddPivotTable ptOriginal
    'Great, our original pivot now just has one item visible in the field of interest
    'So we can delete the slicer connection
    sc.Delete
End Function


Private Function FilterPivot_Routine(Optional rngPivotField As Range, Optional rngFilterItems As Range, Optional bInverse As Boolean = False) As Boolean
' Copyright ©2013 Jeff Weir
' weir.jeff@gmail.com
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' ---------------------------------------------------------------------

'   Date        Initial     Version Details

'   20131113    JSW         007     Initial Programming
'   20131203    JSW         008     Added Inverse Option
'   20140503    JSW         009     Changed so works in pre Excel 2010
'   20140503    JSW         010     Changed so pi.format check not performed in Excel 2013 +
'   20150223    JSW         011     Added check to ensure pfOriginal has .EnableMultiplePageItems set to TRUE if it is a pagefield.
'   20150429    JSW         012     Turned off events, cleared pfOriginal filter.


 
'#############
'#  Remarks  #
'#############

'   This code needs to be called by a wrapper function.
'   e.g.

'   Sub FilterPivot()
'    FilterPivot_Routine
'    End Sub

'    Sub FilterPivot_Inverse()
'    FilterPivot_Routine bInverse:=True
'    End Sub

'   If required, that wrapper function can also provide ranges
'   specifying what PivotField to filter, and where the range of
'   filter terms is. e.g.:
'       FilterPivot_Routine  Range("A2"), Range("C2:C20000")
'   ...or
'       FilterPivot_Routine  ActiveCell, [tblFilterItems]



    Dim ptOriginal As PivotTable
    Dim ptTemp As PivotTable
    Dim pfOriginal As PivotField
    Dim pfTemp As PivotField
    Dim pfFilterItems As PivotField
    Dim lngFilterItems As Long
    Dim pi As PivotItem
    Dim ptFilterItems As PivotTable
    Dim wksTemp As Worksheet
    Dim wksPivot As Worksheet
    Dim dic As Object
    Dim varContinue As Variant
    Dim strMessage As String
    Dim varFormat As Variant
    Dim bDateFormat As Boolean
    Dim bDateWarning As Boolean
    Dim bFirstItemVisible As Boolean
    Dim varFirstItemVisible As Variant

   
   
    FilterPivot_Routine = False   'Assume failure

    On Error GoTo errhandler
    Set wksPivot = ActiveSheet

    'If neccessary, prompt user for the pivotfield of interest
    If rngPivotField Is Nothing Then
        On Error Resume Next
        Set rngPivotField = ActiveCell
        Set pfOriginal = rngPivotField.PivotField    'Tests if this is in fact a PivotField
        If Err <> 0 Then
            Err.Clear
            Set rngPivotField = Nothing
            Set rngPivotField = Application.InputBox( _
                                Title:="Where is the PivotField?", _
                                Prompt:="Please select a cell in the PivotField you want to filter", _
                                Type:=8)
            On Error GoTo errhandler
            If rngPivotField Is Nothing Then Err.Raise 996
        End If
        On Error GoTo errhandler
    End If

    Set pfOriginal = rngPivotField.PivotField
    Set ptOriginal = pfOriginal.Parent
    
    With pfOriginal
        If .Orientation = xlPageField Then
            If .EnableMultiplePageItems = False Then
                .EnableMultiplePageItems = True
                .ClearAllFilters
            End If
        End If
    End With

    'If neccessary, prompt user for FilterItems table related to the pivotfield of interest
    If rngFilterItems Is Nothing Then
        On Error Resume Next
        Set rngFilterItems = Application.InputBox( _
                             Title:="Where are the filter items?", _
                             Prompt:="Please select the range where your filter terms are.", _
                             Type:=8)
        On Error GoTo errhandler
        If rngFilterItems Is Nothing Then Err.Raise 996
    End If

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
   
    ' Excel stores dates differently between PivotItems and Variant Arrays.
   
    ' For instance:
    '    ? CStr(varFilterItems(i, 1))
    '    1/01/2013
    '    ? pi.Value
    '    1/1/2013
    '    ? CStr(varFilterItems(i, 1)) = pi.Value
    '    False

    'So we 'll turn our FilterItems into a PivotTable to ensure formats are treated the same.

    Set wksTemp = Sheets.Add
    rngFilterItems.Copy wksTemp.Range("A2")
    wksTemp.Range("A1").Value = "FilterItems"
    Set rngFilterItems = wksTemp.Range("A2").CurrentRegion
   
    On Error GoTo errhandler

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        rngFilterItems).CreatePivotTable _
        TableDestination:=[C1], TableName:="appFilterItems"
         
    Set ptFilterItems = wksTemp.PivotTables("appFilterItems")
    Set pfFilterItems = ptFilterItems.PivotFields(1)

     ' Add FILTERItems to a Dictionary
    Set dic = CreateObject("scripting.dictionary")
    For Each pi In pfFilterItems.PivotItems
        dic.Add pi.Value, 1 'The one does nothing
    Next

   ptOriginal.ManualUpdate = True  'dramatically speeds up the routine, because the pivot won't recalculate until we're done

       
    'Check if PFOriginal is formatted as a date field.
    ' Basically there is a bug in Excel whereby if you try to do some things
    ' to a PivotItem containing a date but the PivotField number format is NOT a date format
    ' then you get an error.
    ' So we'll check the PivotField date format and see what it is
    ' Note that if a PivotField is based on a range that contains multiple formats
    ' then you get an error simply by checking what the PivotField number format is.
    ' So we'll instigate an On Error Resume Next to handle this
   
    On Error Resume Next
    varFormat = pfOriginal.NumberFormat
    On Error GoTo errhandler
    If IsDate(Format(1, varFormat)) Then bDateFormat = True
   
    If bInverse Then
        lngFilterItems = pfOriginal.PivotItems.Count - rngFilterItems.Count
    Else: lngFilterItems = rngFilterItems.Count
    End If
   
    If lngFilterItems / pfOriginal.PivotItems.Count < 0.5 And Application.Version >= 14 Then
    
        '====================================================================================
        ' If it's likely that less than half of the source Pivot Field's
        ' items will be visible when we're done, then it will be quickest to hide all but one
        ' item and then unhide the PivotItems that match the filter terms
        
        ' Iterating through a large pivot setting all but one item to hidden is slow.
        ' And there's no way to directly do this except in Page Fields, and
        ' that method doesn't let you select multiple items anyway.
        ' Plus, as soon as you drag a page field with just one item showing to
        ' a row field, Excel clears the filter, so that all items are visible again.

        ' So we'll use a trick:
        '  *  make the pf of interest in ptTemp a page field
        '  *  turn off multiple items and select just one PivotItem
        '  *  connect it to the original pivot with a slicer
        ' This will very quickly sync up the field on the original pivot so that only one field is showing.
        
        ' NOTE: WE CAN ONLY DO THIS IF USING EXCEL 2010 OR LATER using the below approach.
        ' If earlier version, we'll use the approach outlined in the ELSE part of this IF block.
        
        ' ALSO NOTE: If a PivotField has a non-Date format, but contains dates, then
        ' we can't programatically hide/show items. So we need to check for this.
        '====================================================================================


        'Identify a suitable item with which to filter the original PivotTable with
        ' As per note above,
        '  *  If the PivotField format is NOT a date format,
        '     then we need to make sure that this first item is NOT a date.
        '     ...because otherwise we can't address it by VBA
        '  *  If the PivotFied format IS a date format, then just use the first item.
        '  *  We'll write that item to a range, then to a variant, so that Excel applies the
        '     same format to it as it does to items in our Filter list
        
        If Not bDateFormat Then
            For Each pi In pfOriginal.PivotItems
                If IsDate(pi.Value) Then
                    If IsNumeric(pi.Value) Then
                        'We need the IsNumeric bit above because
                        'VBA thinks that some decimals encased in strings e.g. "1.1" are dates
                        'So we need to check whether this is a decimal and NOT a date
                        varFirstItemVisible = pi.Value
                        Exit For
                    Else:
                        If Not bDateWarning Then
                            Err.Raise Number:=997, Description:="Can't filter dates"
                        End If
                    End If
                Else:
                    varFirstItemVisible = pi.Value
                    Exit For
                End If
            Next
        Else:
            varFirstItemVisible = pfOriginal.PivotItems(1).Value
        End If
       
        Set ptTemp = ptOriginal.PivotCache.CreatePivotTable(TableDestination:=wksTemp.Range("F1"))
        Set pfTemp = ptTemp.PivotFields(pfOriginal.SourceName)
       
        With pfTemp
            .Orientation = xlPageField
            .ClearAllFilters
            .EnableMultiplePageItems = False
            .CurrentPage = pfTemp.PivotItems(varFirstItemVisible).Value
        End With

        Call FilterPivot_Slicers(ptTemp, pfTemp, ptOriginal)

        ' Check if FirstItemVisible should be visible or hidden when we are done
       If dic.Exists(varFirstItemVisible) Then bFirstItemVisible = True

       
        ' Now try and add the PivotItems.
        ' If there's an error, we'll know that this item is also in the FilterTerms
        On Error Resume Next
        With dic
        
        'The Not bInverse bit in the code blocks below effectively 'flip' the test "If Err.Number <> 0" to "If Err.Number = 0"
        'in the case that bInverse argument is TRUE (meaning we want the Pivot to be filtered on things
        ' NOT in the list of search terms)
        
            If Application.Version >= 15 Then
                For Each pi In pfOriginal.PivotItems
                      dic.Add pi.Value, 1 'The 1 does nothing
                      If Err.Number <> 0 = Not bInverse Then
                        pi.Visible = True
                    End If
                        Err.Clear
                Next
            Else:   'There's a bug in previous versions where you can't use .Visible for dates
                    'if the PivotField is set to General format.
                For Each pi In pfOriginal.PivotItems
                    dic.Add pi.Value, 1 'The 1 does nothing
                    If Err.Number <> 0 = Not bInverse Then
                        ' This item exists in our search term list, so we should unhide it
                        ' Note that due to a bug in Excel 2010, if this item is a date
                        ' but the PivotField format is NOT a date format, we can't
                        ' programatically hide/show items, so we'll have to check this first
                        If Not bDateFormat Then
                            If Not IsNumeric(pi.Value) Then
                                'We need the Not IsNumeric bit above because VBA thinks that
                                ' some decimals encased in strings e.g."1.1" are dates
                                If IsDate(pi.Value) Then
                                    If Not bDateWarning Then
                                        On Error GoTo errhandler
                                        Err.Raise Number:=997, Description:="Can't filter dates"
                                        On Error Resume Next
                                    End If
                                Else: pi.Visible = True
                                End If
                            Else: pi.Visible = True
                            End If
                        Else: pi.Visible = True
                        End If
                    End If
                    Err.Clear
                Next
            End If 'If Application.Version >= 15 Then
            
        End With

        If Not bFirstItemVisible = Not bInverse Then
            pfOriginal.PivotItems(varFirstItemVisible).Visible = False
            If Err.Number <> 0 Then
                MsgBox "None of the filter items were found in the Pivot"
                pfOriginal.ClearAllFilters
                Err.Clear
            End If
        End If

    Else:
        ' If it's likely that MORE than half of the source Pivot Field's items will be visible
        ' when we're done, then it's quickest to unhide all PivotItems and then hide the
        ' PivotItems that DON'T match the filter terms
        
        pfOriginal.ClearAllFilters

        ' Now try and add the PivotItems.
        ' If there's an error, we'll know that this item is in the FilterItems
        ' Otherwise we'll hide it
       
        On Error Resume Next
        With dic
            If Application.Version >= 15 Then
                For Each pi In pfOriginal.PivotItems
                    dic.Add pi.Value, 1 'The 1 does nothing
                    If Err.Number = 0 = Not bInverse Then pi.Visible = False
                    Err.Clear
                Next
            Else:
                 For Each pi In pfOriginal.PivotItems
                    dic.Add pi.Value, 1 'The 1 does nothing
                    If Err.Number = 0 = Not bInverse Then
                        'The Not bInverse bit effectively 'flips' the test "If Err.Number = 0" to "If Err.Number <> 0"
                        'in the case that bInverse argument is TRUE (meaning we want the Pivot to be filtered on things
                        ' NOT in the list of search terms)
                        
                        'This PivotItem NOT in FilterItems list. So hide it
                        'Note that IF this item is a date but the PivotField format is NOT a date format,
                        ' then we can't programatically hide/show items, so we'll have to check this first
                        If Not bDateFormat Then
                            If Not IsNumeric(pi.Value) Then
                                'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates
                                If IsDate(pi.Value) Then
                                    If Not bDateWarning Then
                                        On Error GoTo errhandler
                                        Err.Raise Number:=997, Description:="Can't filter dates"
                                        On Error Resume Next
                                    End If
                                Else: pi.Visible = False 'This item does not exist in the FilterItems. So hide it
                                End If
                            Else: pi.Visible = False 'This item does not exist in the FilterItems. So hide it
                            End If
                        Else: pi.Visible = False
                        End If
                    End If
                    Err.Clear
                Next
            End If 'If Application.Version >= 15 Then
        End With
        
    End If 'If lngFilterItems / pfOriginal.PivotItems.Count < 0.5 And Application.Version >= 14 Then
    On Error GoTo errhandler
    FilterPivot_Routine = True

errhandler:
    If Err.Number <> 0 Then
        Select Case Err.Number
        Case Is = 0:    'No error - do nothing
        Case Is = 996:    'Operation Cancelled
        Case Is = 997:    'Can't filter dates
            strMessage = "*** WARNING...I can't correctly filter dates in this Pivot ***"
            strMessage = strMessage & vbNewLine & vbNewLine
            strMessage = strMessage & "I've found at least one date in this PivotField. "
            strMessage = strMessage & "Unfortunately due to a bug in Excel, if you have dates "
            strMessage = strMessage & " in a PivotField AND that PivotField is NOT formatted "
            strMessage = strMessage & " with a date format, then dates "
            strMessage = strMessage & " can't be programatically filtered either in or out. "
            strMessage = strMessage & vbNewLine & vbNewLine
            strMessage = strMessage & " So you'll have to manually check to see whether "
            strMessage = strMessage & " date items appear as they should."
            strMessage = strMessage & vbNewLine & vbNewLine
            strMessage = strMessage & "Do you want me to continue anyway? "
            varContinue = MsgBox(Prompt:=strMessage, Buttons:=vbYesNo, Title:="Sorry, can't filter dates")
            If varContinue = 6 Then
                bDateWarning = True
                Resume Next
            Else: pfOriginal.ClearAllFilters
            End If
        Case Is = 998:    'Can't filter Datafields
            MsgBox "Oops, you can't filter a DataField." & vbNewLine & vbNewLine & "Please select a RowField, ColumnField, or PageField and try again.", vbCritical, "Can't filter Datafields"
        Case Is = 999:    'no pivotfield selected
            MsgBox "Oops, you haven't selected a pivotfield." & vbNewLine & vbNewLine & "Please select a RowField, ColumnField, or PageField and try again.", vbCritical, "No PivotField selected"
        Case Else:
            MsgBox "Whoops, something went wrong"
        End Select
    End If

    With Application
        If Not wksTemp Is Nothing Then
            .DisplayAlerts = False
            wksTemp.Delete
            .DisplayAlerts = True
        End If
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    If Not ptOriginal Is Nothing Then ptOriginal.ManualUpdate = False

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

408

409

410

411

412

413

414

415

416

417

418

419

420

421

422

423

424

425

426

427

428

429

430

431

432

433

434

435

436

437

438

439

440

441

442

443

444

445

446

447

448

449

450

451

452

453

454

455

456

457

458

459

460

461

462

463

464

465

466

467

468

469

470

471

472

473

474

475

476

477

478

479

480

481

482

483

484

485

486

487

488

489

490

491

492

493

494

495

496

497

498

499

500

501

502

503

504

505

506

507

508

509

510

511

512

513

514

515

516

517

518

519

520

521

522

523

524

525

526

527

528

529

Option Explicit

Sub FilterPivot()

' Description: Wrapper function for my FilterPivot Function

' (Required in the event that a user wants to trigger the FilterPivot

' function and specify parameters at runtime, instead of programatiacally

' calling the routine)

' Programmer: Jeff Weir

' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

' Name/Version: Date: Ini: Modification:

' FilterPivot 20150305 JSW Initial programming

FilterPivot_Routine

End Sub

Sub FilterPivot_Invert()

' Description: Wrapper function for my FilterPivot_Inverse Function

' Inverts the current selection

' (Required in the event that a user wants to trigger the FilterPivot_Inverse

' function and specify parameters at runtime, instead of programatiacally

' calling the routine)

' Programmer: Jeff Weir

' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

' Name/Version: Date: Ini: Modification:

' FilterPivot_Inverse 20150305 JSW Initial programming

FilterPivot_Routine ActiveCell.PivotField.DataRange, ActiveCell.PivotField.DataRange, bInverse:=True

End Sub

Sub FilterPivot_Inverse()

' Description: Wrapper function for my FilterPivot_Inverse Function

' (Required in the event that a user wants to trigger the FilterPivot_Inverse

' function and specify parameters at runtime, instead of programatiacally

' calling the routine)

' Programmer: Jeff Weir

' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

' Name/Version: Date: Ini: Modification:

' FilterPivot_Inverse 20150305 JSW Initial programming

FilterPivot_Routine bInverse:=True

End Sub

Private Sub FilterPivot_AddRightClick()

' Description: Adds "Filter Pivotfield" shortcuts to PivotTable right-click menu

' Programmer: Jeff Weir

' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

' Name/Version: Date: Ini: Modification:

' AddShortcuts 20150305 JSW Initial programming

Dim cbr As CommandBar

Dim sMessage As String

Set cbr = Application.CommandBars("PivotTable Context Menu")

With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)

.Caption = "Filter Pivotfield"

.Tag = "FilterPivotField"

.OnAction = "FilterPivot"

.Style = msoButtonIconAndCaption

.Picture = Application.CommandBars.GetImageMso("FilterAdvancedByForm", 16, 16)

End With

With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)

.Caption = "Inversely Filter Pivotfield"

.Tag = "FilterPivotField"

.OnAction = "FilterPivot_Inverse"

.Style = msoButtonIconAndCaption

.Picture = Application.CommandBars.GetImageMso("FilterAdvancedMenu", 16, 16)

End With

sMessage = "Cool, I've added an option for you to trigger this code by right-clicking "

sMessage = sMessage & "the PivotTable field that you want to filter."

sMessage = sMessage & vbNewLine & vbNewLine & "Happy filtering!"

MsgBox sMessage, vbOKOnly, "Right-click options added..."

End Sub

Private Sub FilterPivot_RemoveRightClick()

' Description: Removes "Filter Pivotfield" shortcuts from PivotTable right-click menu

' Programmer: Jeff Weir

' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

' Name/Version: Date: Ini: Modification:

' AddShortcuts 20150305 JSW Initial programming

Dim cbr As CommandBar

Dim sMessage As String

Dim ctrl As CommandBarControl

Set cbr = Application.CommandBars("PivotTable Context Menu")

For Each ctrl In cbr.Controls

If ctrl.Tag = "FilterPivotField" Then ctrl.Delete

sMessage = "Cool, I've removed the RightClick options for the FilterPivot routines."

MsgBox sMessage, vbOKOnly, "Right-click options added..."

End Sub

Private Function FilterPivot_Slicers(ptTemp As PivotTable, pfTemp As PivotField, ptOriginal As PivotTable)

Dim sc As SlicerCache

' This sub-function contains code that requires Slicers

' It's in this stand-alone function, becaues it only gets called if user has Excel 2010 or later

' If it was incorporated DIRECTY within the FilterPivot function, that function wouldn't compile on pre 2010 machines

Set sc = ActiveWorkbook.SlicerCaches.Add(ptTemp, pfTemp)

sc.PivotTables.AddPivotTable ptOriginal

'Great, our original pivot now just has one item visible in the field of interest

'So we can delete the slicer connection

sc.Delete

End Function

Private Function FilterPivot_Routine(Optional rngPivotField As Range, Optional rngFilterItems As Range, Optional bInverse As Boolean = False) As Boolean

' weir.jeff@gmail.com

' You are free to use this code within your own applications, add-ins,

' documents etc but you are expressly forbidden from selling or

' otherwise distributing this source code without prior consent.

' This includes both posting free demo projects made from this

' code as well as reproducing the code in text or html format.

' ---------------------------------------------------------------------

' Date Initial Version Details

' 20131113 JSW 007 Initial Programming

' 20131203 JSW 008 Added Inverse Option

' 20140503 JSW 009 Changed so works in pre Excel 2010

' 20140503 JSW 010 Changed so pi.format check not performed in Excel 2013 +

' 20150223 JSW 011 Added check to ensure pfOriginal has .EnableMultiplePageItems set to TRUE if it is a pagefield.

' 20150429 JSW 012 Turned off events, cleared pfOriginal filter.

'#############

'# Remarks #

'#############

' This code needs to be called by a wrapper function.

' e.g.

' Sub FilterPivot()

' FilterPivot_Routine

' End Sub

' Sub FilterPivot_Inverse()

' FilterPivot_Routine bInverse:=True

' End Sub

' If required, that wrapper function can also provide ranges

' specifying what PivotField to filter, and where the range of

' filter terms is. e.g.:

' FilterPivot_Routine Range("A2"), Range("C2:C20000")

' ...or

' FilterPivot_Routine ActiveCell, [tblFilterItems]

Dim ptOriginal As PivotTable

Dim ptTemp As PivotTable

Dim pfOriginal As PivotField

Dim pfTemp As PivotField

Dim pfFilterItems As PivotField

Dim lngFilterItems As Long

Dim pi As PivotItem

Dim ptFilterItems As PivotTable

Dim wksTemp As Worksheet

Dim wksPivot As Worksheet

Dim dic As Object

Dim varContinue As Variant

Dim strMessage As String

Dim varFormat As Variant

Dim bDateFormat As Boolean

Dim bDateWarning As Boolean

Dim bFirstItemVisible As Boolean

Dim varFirstItemVisible As Variant

FilterPivot_Routine = False 'Assume failure

On Error GoTo errhandler

Set wksPivot = ActiveSheet

'If neccessary, prompt user for the pivotfield of interest

If rngPivotField Is Nothing Then

On Error Resume Next

Set rngPivotField = ActiveCell

Set pfOriginal = rngPivotField.PivotField 'Tests if this is in fact a PivotField

If Err <> 0 Then

Err.Clear

Set rngPivotField = Nothing

Set rngPivotField = Application.InputBox( _

Title:="Where is the PivotField?", _

Prompt:="Please select a cell in the PivotField you want to filter", _

Type:=8)

On Error GoTo errhandler

If rngPivotField Is Nothing Then Err.Raise 996

End If

On Error GoTo errhandler

End If

Set pfOriginal = rngPivotField.PivotField

Set ptOriginal = pfOriginal.Parent

With pfOriginal

If .Orientation = xlPageField Then

If .EnableMultiplePageItems = False Then

.EnableMultiplePageItems = True

.ClearAllFilters

End If

End With

'If neccessary, prompt user for FilterItems table related to the pivotfield of interest

If rngFilterItems Is Nothing Then

On Error Resume Next

Set rngFilterItems = Application.InputBox( _

Title:="Where are the filter items?", _

Prompt:="Please select the range where your filter terms are.", _

Type:=8)

On Error GoTo errhandler

If rngFilterItems Is Nothing Then Err.Raise 996

End If

With Application

.ScreenUpdating = False

.Calculation = xlCalculationManual

.EnableEvents = False

End With

' Excel stores dates differently between PivotItems and Variant Arrays.

' For instance:

' ? CStr(varFilterItems(i, 1))

' 1/01/2013

' ? pi.Value

' 1/1/2013

' ? CStr(varFilterItems(i, 1)) = pi.Value

' False

'So we 'll turn our FilterItems into a PivotTable to ensure formats are treated the same.

Set wksTemp = Sheets.Add

rngFilterItems.Copy wksTemp.Range("A2")

wksTemp.Range("A1").Value = "FilterItems"

Set rngFilterItems = wksTemp.Range("A2").CurrentRegion

On Error GoTo errhandler

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _

rngFilterItems).CreatePivotTable _

TableDestination:=[C1], TableName:="appFilterItems"

Set ptFilterItems = wksTemp.PivotTables("appFilterItems")

Set pfFilterItems = ptFilterItems.PivotFields(1)

' Add FILTERItems to a Dictionary

Set dic = CreateObject("scripting.dictionary")

For Each pi In pfFilterItems.PivotItems

dic.Add pi.Value, 1 'The one does nothing

ptOriginal.ManualUpdate = True 'dramatically speeds up the routine, because the pivot won't recalculate until we're done

'Check if PFOriginal is formatted as a date field.

' Basically there is a bug in Excel whereby if you try to do some things

' to a PivotItem containing a date but the PivotField number format is NOT a date format

' then you get an error.

' So we'll check the PivotField date format and see what it is

' Note that if a PivotField is based on a range that contains multiple formats

' then you get an error simply by checking what the PivotField number format is.

' So we'll instigate an On Error Resume Next to handle this

On Error Resume Next

varFormat = pfOriginal.NumberFormat

On Error GoTo errhandler

If IsDate(Format(1, varFormat)) Then bDateFormat = True

If bInverse Then

lngFilterItems = pfOriginal.PivotItems.Count - rngFilterItems.Count

Else: lngFilterItems = rngFilterItems.Count

End If

If lngFilterItems / pfOriginal.PivotItems.Count < 0.5 And Application.Version >= 14 Then

'====================================================================================

' If it's likely that less than half of the source Pivot Field's

' items will be visible when we're done, then it will be quickest to hide all but one

' item and then unhide the PivotItems that match the filter terms

' Iterating through a large pivot setting all but one item to hidden is slow.

' And there's no way to directly do this except in Page Fields, and

' that method doesn't let you select multiple items anyway.

' Plus, as soon as you drag a page field with just one item showing to

' a row field, Excel clears the filter, so that all items are visible again.

' So we'll use a trick:

' * make the pf of interest in ptTemp a page field

' * turn off multiple items and select just one PivotItem

' * connect it to the original pivot with a slicer

' This will very quickly sync up the field on the original pivot so that only one field is showing.

' NOTE: WE CAN ONLY DO THIS IF USING EXCEL 2010 OR LATER using the below approach.

' If earlier version, we'll use the approach outlined in the ELSE part of this IF block.

' ALSO NOTE: If a PivotField has a non-Date format, but contains dates, then

' we can't programatically hide/show items. So we need to check for this.

'====================================================================================

'Identify a suitable item with which to filter the original PivotTable with

' As per note above,

' * If the PivotField format is NOT a date format,

' then we need to make sure that this first item is NOT a date.

' ...because otherwise we can't address it by VBA

' * If the PivotFied format IS a date format, then just use the first item.

' * We'll write that item to a range, then to a variant, so that Excel applies the

' same format to it as it does to items in our Filter list

If Not bDateFormat Then

For Each pi In pfOriginal.PivotItems

If IsDate(pi.Value) Then

If IsNumeric(pi.Value) Then

'We need the IsNumeric bit above because

'VBA thinks that some decimals encased in strings e.g. "1.1" are dates

'So we need to check whether this is a decimal and NOT a date

varFirstItemVisible = pi.Value

Exit For

Else:

If Not bDateWarning Then

Err.Raise Number:=997, Description:="Can't filter dates"

End If

Else:

varFirstItemVisible = pi.Value

Exit For

End If

Else:

varFirstItemVisible = pfOriginal.PivotItems(1).Value

End If

Set ptTemp = ptOriginal.PivotCache.CreatePivotTable(TableDestination:=wksTemp.Range("F1"))

Set pfTemp = ptTemp.PivotFields(pfOriginal.SourceName)

With pfTemp

.Orientation = xlPageField

.ClearAllFilters

.EnableMultiplePageItems = False

.CurrentPage = pfTemp.PivotItems(varFirstItemVisible).Value

End With

Call FilterPivot_Slicers(ptTemp, pfTemp, ptOriginal)

' Check if FirstItemVisible should be visible or hidden when we are done

If dic.Exists(varFirstItemVisible) Then bFirstItemVisible = True

' Now try and add the PivotItems.

' If there's an error, we'll know that this item is also in the FilterTerms

On Error Resume Next

With dic

'The Not bInverse bit in the code blocks below effectively 'flip' the test "If Err.Number <> 0" to "If Err.Number = 0"

'in the case that bInverse argument is TRUE (meaning we want the Pivot to be filtered on things

' NOT in the list of search terms)

If Application.Version >= 15 Then

For Each pi In pfOriginal.PivotItems

dic.Add pi.Value, 1 'The 1 does nothing

If Err.Number <> 0 = Not bInverse Then

pi.Visible = True

End If

Err.Clear

Else: 'There's a bug in previous versions where you can't use .Visible for dates

'if the PivotField is set to General format.

For Each pi In pfOriginal.PivotItems

dic.Add pi.Value, 1 'The 1 does nothing

If Err.Number <> 0 = Not bInverse Then

' This item exists in our search term list, so we should unhide it

' Note that due to a bug in Excel 2010, if this item is a date

' but the PivotField format is NOT a date format, we can't

' programatically hide/show items, so we'll have to check this first

If Not bDateFormat Then

If Not IsNumeric(pi.Value) Then

'We need the Not IsNumeric bit above because VBA thinks that

' some decimals encased in strings e.g."1.1" are dates

If IsDate(pi.Value) Then

If Not bDateWarning Then

On Error GoTo errhandler

Err.Raise Number:=997, Description:="Can't filter dates"

On Error Resume Next

End If

Else: pi.Visible = True

End If

Else: pi.Visible = True

End If

Else: pi.Visible = True

End If

Err.Clear

End If 'If Application.Version >= 15 Then

End With

If Not bFirstItemVisible = Not bInverse Then

pfOriginal.PivotItems(varFirstItemVisible).Visible = False

If Err.Number <> 0 Then

MsgBox "None of the filter items were found in the Pivot"

pfOriginal.ClearAllFilters

Err.Clear

End If

Else:

' If it's likely that MORE than half of the source Pivot Field's items will be visible

' when we're done, then it's quickest to unhide all PivotItems and then hide the

' PivotItems that DON'T match the filter terms

pfOriginal.ClearAllFilters

' Now try and add the PivotItems.

' If there's an error, we'll know that this item is in the FilterItems

' Otherwise we'll hide it

On Error Resume Next

With dic

If Application.Version >= 15 Then

For Each pi In pfOriginal.PivotItems

dic.Add pi.Value, 1 'The 1 does nothing

If Err.Number = 0 = Not bInverse Then pi.Visible = False

Err.Clear

Else:

For Each pi In pfOriginal.PivotItems

dic.Add pi.Value, 1 'The 1 does nothing

If Err.Number = 0 = Not bInverse Then

'The Not bInverse bit effectively 'flips' the test "If Err.Number = 0" to "If Err.Number <> 0"

'in the case that bInverse argument is TRUE (meaning we want the Pivot to be filtered on things

' NOT in the list of search terms)

'This PivotItem NOT in FilterItems list. So hide it

'Note that IF this item is a date but the PivotField format is NOT a date format,

' then we can't programatically hide/show items, so we'll have to check this first

If Not bDateFormat Then

If Not IsNumeric(pi.Value) Then

'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates

If IsDate(pi.Value) Then

If Not bDateWarning Then

On Error GoTo errhandler

Err.Raise Number:=997, Description:="Can't filter dates"

On Error Resume Next

End If

Else: pi.Visible = False 'This item does not exist in the FilterItems. So hide it

End If

Else: pi.Visible = False 'This item does not exist in the FilterItems. So hide it

End If

Else: pi.Visible = False

End If

Err.Clear

End If 'If Application.Version >= 15 Then

End With

End If 'If lngFilterItems / pfOriginal.PivotItems.Count < 0.5 And Application.Version >= 14 Then

On Error GoTo errhandler

FilterPivot_Routine = True

errhandler:

If Err.Number <> 0 Then

Select Case Err.Number

Case Is = 0: 'No error - do nothing

Case Is = 996: 'Operation Cancelled

Case Is = 997: 'Can't filter dates

strMessage = "*** WARNING...I can't correctly filter dates in this Pivot ***"

strMessage = strMessage & vbNewLine & vbNewLine

strMessage = strMessage & "I've found at least one date in this PivotField. "

strMessage = strMessage & "Unfortunately due to a bug in Excel, if you have dates "

strMessage = strMessage & " in a PivotField AND that PivotField is NOT formatted "

strMessage = strMessage & " with a date format, then dates "

strMessage = strMessage & " can't be programatically filtered either in or out. "

strMessage = strMessage & vbNewLine & vbNewLine

strMessage = strMessage & " So you'll have to manually check to see whether "

strMessage = strMessage & " date items appear as they should."

strMessage = strMessage & vbNewLine & vbNewLine

strMessage = strMessage & "Do you want me to continue anyway? "

varContinue = MsgBox(Prompt:=strMessage, Buttons:=vbYesNo, Title:="Sorry, can't filter dates")

If varContinue = 6 Then

bDateWarning = True

Resume Next

Else: pfOriginal.ClearAllFilters

End If

Case Is = 998: 'Can't filter Datafields

MsgBox "Oops, you can't filter a DataField." & vbNewLine & vbNewLine & "Please select a RowField, ColumnField, or PageField and try again.", vbCritical, "Can't filter Datafields"

Case Is = 999: 'no pivotfield selected

MsgBox "Oops, you haven't selected a pivotfield." & vbNewLine & vbNewLine & "Please select a RowField, ColumnField, or PageField and try again.", vbCritical, "No PivotField selected"

Case Else:

MsgBox "Whoops, something went wrong"

End Select

End If

With Application

If Not wksTemp Is Nothing Then

.DisplayAlerts = False

wksTemp.Delete

.DisplayAlerts = True

End If

.ScreenUpdating = True

.Calculation = xlCalculationAutomatic

.EnableEvents = True

End With

If Not ptOriginal Is Nothing Then ptOriginal.ManualUpdate = False

End Function

Much ado about ADO

Posted on November 28, 2013March 17, 2018 by Jeff Weir

Jeff here again. I had a crack at rewriting my Unpivot via SQL routine, to see if I could make it simpler and faster. The point of the routine is to let you turn a very large cross-tab directly into a PivotTable in the case that a flat file would be too long to fit in Excel’s grid. The original routine works by making a temp copy of the file (to avoid Memory Leak) and then doing lots and lots of UNION ALLs against that temp copy to unwind it one cross-tab column at a time. (The reason we need those UNION ALLs is that there is no UNPIVOT command in the pigeon English dialect of SQL that Excel and Access speak.) My routine then executes the SQL via ADO, and creates a Pivot directly out of the resulting RecordSet.

So if we had a data set that looked like this:

…then the resulting SQL looks something like this:

SELECT [Country], [Sector], [Base year (Convention)], [1990] AS Total, '1990' AS [Year] FROM [Data$A18:H28] UNION ALL SELECT [Country], [Sector], [Base year (Convention)], [1991] AS Total, '1991' AS [Year] FROM [Data$A18:H28] UNION ALL SELECT [Country], [Sector], [Base year (Convention)], [1992] AS Total, '1992' AS [Year] FROM [Data$A18:H28] UNION ALL SELECT [Country], [Sector], [Base year (Convention)], [1993] AS Total, '1993' AS [Year] FROM [Data$A18:H28] UNION ALL SELECT [Country], [Sector], [Base year (Convention)], [1994] AS Total, '1994' AS [Year] FROM [Data$A18:H28]

But as per my previous post, the code to accomplish this is pretty long. This is partly because the Microsoft JET/ACE Database engine has a hard limit of 50 ‘UNION ALL’ clauses, which you will soon exceed if you have a big cross-tab. I get around this limit by creating sub-blocks of SELECT/UNION ALL statements under this limit, and then stitching these sub-blocks with an outer UNION ALL ‘wrapper’. But that results in fairly complicated code and presumably quite a bit of work for the JET/ACE driver.

So I got to thinking that rather than using all those UNION ALLs to create the RecordSet with SQL, why not just populate a disconnected RecordSet directly from an amended version of snb’s elegant code, like so:

Sub UnPivotViaRecordset(rngCrosstab As Range, rngLeftHeaders As Range, rngRightHeaders As Range, strCrosstabName As String)

Dim rs As Object 'We're using late binding. If we were using early, we'd use Dim rs ADODB.Recordset
Dim pc As PivotCache
Dim pt As PivotTable
Dim wks As Worksheet
Dim rng As Range
Dim lngRecords As Long
Dim timetaken As Date
Dim cell As Range
Dim varSource As Variant
Dim lRightColumns As Long
Dim lLeftColumns As Long
Dim j As Long
Dim n As Long
Dim m As Long
Dim i As Long

    timetaken = Now()
    On Error GoTo 0
    Set rs = CreateObject("ADODB.Recordset")
    With rs
        For Each cell In rngLeftHeaders
            .Fields.append cell.Value, adVarChar, 150
        Next cell
        .Fields.append strCrosstabName, adVarChar, 150
        .Fields.append "Value", adDouble
        
        .CursorLocation = adUseClient
        .CursorType = 2 ' adLockPessimistic
        .Open

        varSource = rngCrosstab
        lRightColumns = rngRightHeaders.Columns.Count
        lLeftColumns = UBound(varSource, 2) - lRightColumns
       
       lngRecords = (UBound(varSource) - 1) * lRightColumns
        For j = 1 To lngRecords
            m = (j - 1) Mod (UBound(varSource) - 1) + 2
            n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1
            .addnew
            i = 1
            For Each cell In rngLeftHeaders
                .Fields(cell.Value) = varSource(m, i)
            i = i + 1
            Next cell
            .Fields(strCrosstabName) = varSource(1, n)
            .Fields("Value") = varSource(m, n)
        Next j
        .movefirst
        
        Set wks = Sheets.Add
        Set rng = wks.Range("A1")
        Set pc = ActiveWorkbook.PivotCaches.Create(xlExternal)
        Set pc.Recordset = rs
        Set pt = pc.CreatePivotTable(TableDestination:=rng)
        
        'Clean Up
        rs.Close
        Set rs = Nothing

    End With
    
    timetaken = timetaken - Now()
    Debug.Print "UnPivot: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")
    
End Sub

Sub UnPivotViaRecordset(rngCrosstab As Range, rngLeftHeaders As Range, rngRightHeaders As Range, strCrosstabName As String)

Dim rs As Object 'We're using late binding. If we were using early, we'd use Dim rs ADODB.Recordset

Dim pc As PivotCache

Dim pt As PivotTable

Dim wks As Worksheet

Dim rng As Range

Dim lngRecords As Long

Dim timetaken As Date

Dim cell As Range

Dim varSource As Variant

Dim lRightColumns As Long

Dim lLeftColumns As Long

Dim j As Long

Dim n As Long

Dim m As Long

Dim i As Long

timetaken = Now()

On Error GoTo 0

Set rs = CreateObject("ADODB.Recordset")

With rs

For Each cell In rngLeftHeaders

.Fields.append cell.Value, adVarChar, 150

Next cell

.Fields.append strCrosstabName, adVarChar, 150

.Fields.append "Value", adDouble

.CursorLocation = adUseClient

.CursorType = 2 ' adLockPessimistic

.Open

varSource = rngCrosstab

lRightColumns = rngRightHeaders.Columns.Count

lLeftColumns = UBound(varSource, 2) - lRightColumns

lngRecords = (UBound(varSource) - 1) * lRightColumns

For j = 1 To lngRecords

m = (j - 1) Mod (UBound(varSource) - 1) + 2

n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1

.addnew

i = 1

For Each cell In rngLeftHeaders

.Fields(cell.Value) = varSource(m, i)

i = i + 1

Next cell

.Fields(strCrosstabName) = varSource(1, n)

.Fields("Value") = varSource(m, n)

Next j

.movefirst

Set wks = Sheets.Add

Set rng = wks.Range("A1")

Set pc = ActiveWorkbook.PivotCaches.Create(xlExternal)

Set pc.Recordset = rs

Set pt = pc.CreatePivotTable(TableDestination:=rng)

'Clean Up

rs.Close

Set rs = Nothing

End With

timetaken = timetaken - Now()

Debug.Print "UnPivot: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")

End Sub

This routine worked fine on a small number of records. For instance, it unwound a cross-tab of 1000 rows x 100 cross-tab columns = 100,000 records in 8 seconds. Not exactly lightning, but it got there.

But it did not work fine on larger ones: at around 2500 rows x 100 cross-tab columns = 250,000 records it returned an Out of Memory error. So that rules the Disconnected RecordSet approach out for unwinding super-size cross-tabs. Unless you’re manipulating small data sets, steer clear of disconnected RecordSets.

Not to be deterred, I thought I’d try a different approach: I amended snb’s original approach so that it split a large flat file across multiple tabs in need, and then wrote a seperate routine to mash together the data in those tabs with SQL. This will result in far fewer UNION ALL’s (one per sheet) than my original code (one per column), and hopefully much faster performance.

Here’s how I revised SNB’s code:

Sub UnPivot_MultipleTabs(rngCrosstab As Range, _
                      rngLeftHeaders As Range, _
                      rngRightHeaders As Range, _
                      strCrosstabName As String)

    Dim varSource As Variant
    Dim lRecords As Long
    Dim lPass As Long
    Dim lPasses As Long
    Dim lArrayLength As Long
    Dim lLeftColumns As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim m As Long
    Dim n As Long
    Dim wksNew As Worksheet
    Dim timetaken As Date
    
    timetaken = Now()
    
    varSource = rngCrosstab
    lRecords = Intersect(rngRightHeaders.EntireColumn, rngCrosstab).Cells.Count
    lPasses = Application.RoundUp(lRecords / Application.Rows.Count, 0)
    lLeftColumns = rngLeftHeaders.Columns.Count
    
    ReDim strWorksheets(1 To lPasses)
    For lPass = 1 To lPasses
        If lPass = lPasses Then
            'The last pass will have a smaller output array
            lArrayLength = (UBound(varSource) - 1) * rngRightHeaders.Columns.Count - (lPasses - 1) * (Application.Rows.Count - 1)
        Else: lArrayLength = Application.Rows.Count - 1
        End If
        ReDim varOutput(1 To lArrayLength, 1 To lLeftColumns + 2)
    
        For j = 1 To UBound(varOutput)
            m = ((lPass - 1) * (Application.Rows.Count - 1) + j - 1) Mod (UBound(varSource) - 1) + 2
            ' Why +2 above?
            ' Because + 1 accounts for the fact that x mod x is zero, but we are using 1-based arrays so must add one
            ' And the other  + 1 accounts for headers
            n = ((lPass - 1) * (Application.Rows.Count - 1) + j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1
            varOutput(j, lLeftColumns + 1) = varSource(1, n)
            varOutput(j, lLeftColumns + 2) = varSource(m, n)
            For i = 1 To lLeftColumns
                varOutput(j, i) = varSource(m, i)
            Next i
        Next j
    
        Set wksNew = Worksheets.Add
        strWorksheets(lPass) = wksNew.Name
    
        With Cells(1, 1)
            .Resize(, lLeftColumns).Value = rngLeftHeaders.Value
            .Offset(, lLeftColumns).Value = strCrosstabName
            .Offset(, lLeftColumns + 1).Value = "Value"
            .Offset(1, 0).Resize(UBound(varOutput), UBound(varOutput, 2)) = varOutput
        End With
    Next lPass
        
    timetaken = timetaken - Now()
    Debug.Print "UnPivot: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")

End Sub

Sub UnPivot_MultipleTabs(rngCrosstab As Range, _

rngLeftHeaders As Range, _

rngRightHeaders As Range, _

strCrosstabName As String)

Dim varSource As Variant

Dim lRecords As Long

Dim lPass As Long

Dim lPasses As Long

Dim lArrayLength As Long

Dim lLeftColumns As Long

Dim i As Long

Dim j As Long

Dim k As Long

Dim m As Long

Dim n As Long

Dim wksNew As Worksheet

Dim timetaken As Date

timetaken = Now()

varSource = rngCrosstab

lRecords = Intersect(rngRightHeaders.EntireColumn, rngCrosstab).Cells.Count

lPasses = Application.RoundUp(lRecords / Application.Rows.Count, 0)

lLeftColumns = rngLeftHeaders.Columns.Count

ReDim strWorksheets(1 To lPasses)

For lPass = 1 To lPasses

If lPass = lPasses Then

'The last pass will have a smaller output array

lArrayLength = (UBound(varSource) - 1) * rngRightHeaders.Columns.Count - (lPasses - 1) * (Application.Rows.Count - 1)

Else: lArrayLength = Application.Rows.Count - 1

End If

ReDim varOutput(1 To lArrayLength, 1 To lLeftColumns + 2)

For j = 1 To UBound(varOutput)

m = ((lPass - 1) * (Application.Rows.Count - 1) + j - 1) Mod (UBound(varSource) - 1) + 2

' Why +2 above?

' Because + 1 accounts for the fact that x mod x is zero, but we are using 1-based arrays so must add one

' And the other + 1 accounts for headers

n = ((lPass - 1) * (Application.Rows.Count - 1) + j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1

varOutput(j, lLeftColumns + 1) = varSource(1, n)

varOutput(j, lLeftColumns + 2) = varSource(m, n)

For i = 1 To lLeftColumns

varOutput(j, i) = varSource(m, i)

Next i

Next j

Set wksNew = Worksheets.Add

strWorksheets(lPass) = wksNew.Name

With Cells(1, 1)

.Resize(, lLeftColumns).Value = rngLeftHeaders.Value

.Offset(, lLeftColumns).Value = strCrosstabName

.Offset(, lLeftColumns + 1).Value = "Value"

.Offset(1, 0).Resize(UBound(varOutput), UBound(varOutput, 2)) = varOutput

End With

Next lPass

timetaken = timetaken - Now()

Debug.Print "UnPivot: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")

End Sub

That part works a treat. Takes around 38 seconds to take a 19780 Row x 100 Column crosstab = 1,977,900 records and spit it out as a flat file in two sheets.

And here’s the code that stiches those together into one PivotTable:

Sub PivotFromTabs(ParamArray strSheetNames() As Variant)

    Dim cell As Range
    Dim wksSource As Worksheet
    Dim pt As PivotTable
    Dim rngCurrentHeader As Range
    Dim timetaken As Date
    Dim strMsg As String
    Dim varAnswer As Variant
    Dim strWorksheets() As String
    Dim sExt As String
    Dim sSQL As String
    Dim arSQL() As String
    Dim arTemp() As String
    Dim sTempFilePath As String
    Dim objPivotCache As PivotCache
    Dim objRS As Object
    Dim oConn As Object
    Dim sConnection As String
    Dim wksNew   As Worksheet

        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' When using ADO with Excel data, there is a documented bug
        ' causing a memory leak unless the data is in a different
        ' workbook from the ADO workbook.
        ' http://support.microsoft.com/kb/319998
        ' So the work-around is to save a temp version somewhere else,
        ' then pull the data from the temp version, then delete the
        ' temp copy
        
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        sTempFilePath = ActiveWorkbook.Path
        If Application.Version >= 12 Then
            'use ACE provider connection string
            'sTempFilePath = sTempFilePath & "\" & "TempFile_223757" & ".xlsx"
            sTempFilePath = sTempFilePath & "\" & "TempFile_" & Format(time(), "hhmmss") & ".xlsx"
            sConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 12.0;IMEX=1;HDR=Yes"";"
        Else:
            'use JET provider connection string
            sTempFilePath = sTempFilePath & "\" & "TempFile_" & Format(time(), "hhmmss") & ".xls"
            sConnection = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 8.0;HDR=Yes"";"
        End If
        
        ActiveWorkbook.SaveCopyAs sTempFilePath
        
        Set objRS = CreateObject("ADODB.Recordset")
        Set oConn = CreateObject("ADODB.Connection")

        sSQL = "SELECT * FROM [" & Join(strSheetNames, "$] UNION ALL SELECT * FROM [") & "$]"
        Debug.Print sSQL
        ' Open the ADO connection to our temp Excel workbook
        oConn.Open sConnection

         ' Open the recordset as a result of executing the SQL query
        objRS.Open Source:=sSQL, ActiveConnection:=oConn, CursorType:=1
        Set objPivotCache = ActiveWorkbook.PivotCaches.Create(xlExternal)
        Set objPivotCache.Recordset = objRS
        Set wksNew = Sheets.Add
        Set pt = objPivotCache.CreatePivotTable(TableDestination:=wksNew.Range("A3"))
 
    'cleanup
        Set objPivotCache = Nothing
        objRS.Close
        oConn.Close
        Set objRS = Nothing
        Set oConn = Nothing
        
        Kill sTempFilePath
End Sub

Sub PivotFromTabs(ParamArray strSheetNames() As Variant)

Dim cell As Range

Dim wksSource As Worksheet

Dim pt As PivotTable

Dim rngCurrentHeader As Range

Dim timetaken As Date

Dim strMsg As String

Dim varAnswer As Variant

Dim strWorksheets() As String

Dim sExt As String

Dim sSQL As String

Dim arSQL() As String

Dim arTemp() As String

Dim sTempFilePath As String

Dim objPivotCache As PivotCache

Dim objRS As Object

Dim oConn As Object

Dim sConnection As String

Dim wksNew As Worksheet

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' When using ADO with Excel data, there is a documented bug

' causing a memory leak unless the data is in a different

' workbook from the ADO workbook.

' http://support.microsoft.com/kb/319998

' So the work-around is to save a temp version somewhere else,

' then pull the data from the temp version, then delete the

' temp copy

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

sTempFilePath = ActiveWorkbook.Path

If Application.Version >= 12 Then

'use ACE provider connection string

'sTempFilePath = sTempFilePath & "\" & "TempFile_223757" & ".xlsx"

sTempFilePath = sTempFilePath & "\" & "TempFile_" & Format(time(), "hhmmss") & ".xlsx"

sConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 12.0;IMEX=1;HDR=Yes"";"

Else:

'use JET provider connection string

sTempFilePath = sTempFilePath & "\" & "TempFile_" & Format(time(), "hhmmss") & ".xls"

sConnection = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 8.0;HDR=Yes"";"

End If

ActiveWorkbook.SaveCopyAs sTempFilePath

Set objRS = CreateObject("ADODB.Recordset")

Set oConn = CreateObject("ADODB.Connection")

sSQL = "SELECT * FROM [" & Join(strSheetNames, "$] UNION ALL SELECT * FROM [") & "$]"

Debug.Print sSQL

' Open the ADO connection to our temp Excel workbook

oConn.Open sConnection

' Open the recordset as a result of executing the SQL query

objRS.Open Source:=sSQL, ActiveConnection:=oConn, CursorType:=1

Set objPivotCache = ActiveWorkbook.PivotCaches.Create(xlExternal)

Set objPivotCache.Recordset = objRS

Set wksNew = Sheets.Add

Set pt = objPivotCache.CreatePivotTable(TableDestination:=wksNew.Range("A3"))

'cleanup

Set objPivotCache = Nothing

objRS.Close

oConn.Close

Set objRS = Nothing

Set oConn = Nothing

Kill sTempFilePath

End Sub

I tested this routine on some sheets with smaller datasets in them initially. Works just fine.

200,000 records in 2 sheets, no problem

But on bigger stuff, weirdsville:
For instance, here’s what I got when I tried to run it on 250,000 records split across two sheets:

What do you mean, “External table is not in the expected format“? It was just a minute ago!

Pushing debug shows that the oConn.Open sConnection line is highlighted. When I pushed F5 then the code ran without hitch, and produced the pivot as expected. So who knows what that was about.

But when I tried it on a larger dataset of 600,000 records in each sheet, I got an ‘Unexpected error from external database driver (1)’ message:

You betcha it’s unexpected! Googling didn’t turn up much, apart from some people having issues trying to get very big datasets from Excel into SQL Server. One person’s problem was solved by adding in imex=1 in the connection string, but it didn’t do anything for me.

I tried running the sub on several sheets with various amounts of records in each. About the maximum I could pull through was 3 sheets of 400,000 rows. But anything bigger, then I got that Unexpected Error From External Database Driver error again.

Next I tried running the code on just one sheet with various rows of data in it, to see what happened. After I push F5 to ignore the External Table Is Not In The Expected Format error, it did manage to produce a pivot in all cases, but the pivot may or may not contain all the data, depending on how many records were in the source sheet. For instance:

If there’s 500,000 records in the flat file I 500,000 records in the pivot.
If there’s 750,000 records in the flat file I only 613,262 records in the pivot. wtf?
If there’s 1,000,000 records in the flat file, I 613,262 records in the pivot again. wtfa?

Whereas my original UNPIVOT BY SQL routine could handle much larger datasets than either the disconnected RecordSet approach or the above one without complaining.

Well screw you, code…I’m giving you an error back:

UnPivot Shootout

Posted on November 21, 2013March 17, 2018 by Jeff Weir

Jeff here, again. PivotTables again. Sorry ’bout that.

snb posted a very concise bit of code to unwind crosstabs over at Unpivot by SQL and so I got to wondering how my much longer routine handled in comparison.

My approach used SQL and lots of Union All statements to do the trick. And lots and lots of code. Whereas snb uses arrays to unwind the crosstab, which is fine so long as you don’t run out of worksheet to post the resulting flat-file in. Which is going to be the case 99.999999% of the time. And frankly, crosstabs in the other 0.000001% of cases deserve to be stuck as crosstabs.

At the same time, I thought I’d also test a previous approach of mine that uses the Multiple Consolidation trick that Mike Alexander outlines at Transposing a Dataset with a PivotTable. This approach:

copies the specific contiguous or non-contiguous columns of data that the user want to turn into a flat file to a new sheet.
concatenates all the columns on the left into one column, while putting the pipe character ‘|’ between each field so that later we can split these apart into separate columns again.
creates a pivot table out of this using Excel’s ‘Multiple Consolidation Ranges’ option. Normally this type of pivot table is used for combining data on different sheets, but it has the side benefit of taking horizontal data and providing a vertical extract once you double click on the Grand Total field. This is also known as a ‘Reverse Pivot’.
splits our pipe-delimited column back into seperate columns, using Excel’s Text-to-Column funcionality.

snb’s approach

snbs’ code for a dataset with two non-pivot fields down the left looked like this:

Sub M_snb()
    sn = Cells(1).CurrentRegion
    x = Cells(1).CurrentRegion.Rows(1).SpecialCells(2).Count
    y = UBound(sn, 2) - x
   
    ReDim sp(1 To x * (UBound(sn) - 1), 1 To 4)
   
    For j = 1 To UBound(sp)
       m = (j - 1) Mod (UBound(sn) - 1) + 2
       n = (j - 1) \ (UBound(sn) - 1) + y + 1
       sp(j, 1) = sn(m, 1)
       sp(j, 2) = sn(m, 2)
       sp(j, 3) = sn(1, n)
       sp(j, 4) = sn(m, n)
    Next
   
    Cells(20, 1).Resize(UBound(sp), UBound(sp, 2)) = sp
End Sub

Sub M_snb()

sn = Cells(1).CurrentRegion

x = Cells(1).CurrentRegion.Rows(1).SpecialCells(2).Count

y = UBound(sn, 2) - x

ReDim sp(1 To x * (UBound(sn) - 1), 1 To 4)

For j = 1 To UBound(sp)

m = (j - 1) Mod (UBound(sn) - 1) + 2

n = (j - 1) \ (UBound(sn) - 1) + y + 1

sp(j, 1) = sn(m, 1)

sp(j, 2) = sn(m, 2)

sp(j, 3) = sn(1, n)

sp(j, 4) = sn(m, n)

Cells(20, 1).Resize(UBound(sp), UBound(sp, 2)) = sp

End Sub

…which I’m sure you’ll all agree falls somewhere on the spectrum between good looking and positivity anorexic. So I put a bit of meat on it’s bones so that it prompts you for ranges and handles any sized cross-tab:

Sub UnPivot_snb()
    Dim varSource As Variant
    Dim j As Long
    Dim m As Long
    Dim n As Long
    Dim i As Long
    Dim varOutput As Variant
    Dim rngCrossTab As Range
    Dim rngLeftHeaders As Range
    Dim rngRightHeaders As Range
    
'Identify where the ENTIRE crosstab table is
        If rngCrossTab Is Nothing Then
            On Error Resume Next
            Set rngCrossTab = Application.InputBox( _
                              Title:="Please select the ENTIRE crosstab", _
                              prompt:="Please select the ENTIRE crosstab that you want to turn into a flat file", _
                              Type:=8, Default:=Selection.CurrentRegion.Address)
            If Err.Number <> 0 Then
                On Error GoTo errhandler
                Err.Raise 999
            Else: On Error GoTo errhandler
            End If
            rngCrossTab.Parent.Activate
            rngCrossTab.Cells(1, 1).Select    'Returns them to the top left of the source table for convenience
        End If

        'Identify range containing columns of interest running down the table
        If rngLeftHeaders Is Nothing Then
            On Error Resume Next
            Set rngLeftHeaders = Application.InputBox( _
                                 Title:="Select the column HEADERS from the LEFT of the table that WON'T be aggregated", _
                                 prompt:="Select the column HEADERS from the LEFT of the table that won't be aggregated", _
                                 Default:=Selection.Address, Type:=8)
            If Err.Number <> 0 Then
                On Error GoTo errhandler
                Err.Raise 999
            Else: On Error GoTo errhandler
            End If
            Set rngLeftHeaders = rngLeftHeaders.Resize(1, rngLeftHeaders.Columns.Count)    'just in case they selected the entire column
            rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1).Select    'Returns them to the right of the range they just selected
        End If


        If rngRightHeaders Is Nothing Then
            'Identify range containing data and cross-tab headers running across the table
            On Error Resume Next
            Set rngRightHeaders = Application.InputBox( _
                                  Title:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
                                  prompt:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
                                  Default:=Selection.Address, _
                                  Type:=8)
             If Err.Number <> 0 Then
                On Error GoTo errhandler
                Err.Raise 999
            Else: On Error GoTo errhandler
            End If
            Set rngRightHeaders = rngRightHeaders.Resize(1, rngRightHeaders.Columns.Count)    'just in case they selected the entire column
            rngCrossTab.Cells(1, 1).Select    'Returns them to the top left of the source table for convenience
        End If


        If strCrosstabName = "" Then
            'Get the field name for the columns being consolidated e.g. 'Country' or 'Project'. note that reserved SQL words like 'Date' cannot be used
            strCrosstabName = Application.InputBox( _
                              Title:="What name do you want to give the data field being aggregated?", _
                              prompt:="What name do you want to give the data field being aggregated? e.g. 'Date', 'Country', etc.", _
                              Default:="Date", _
                              Type:=2)
             If strCrosstabName = "False" Then Err.Raise 999
        End If

    timetaken = Now()

    varSource = rngCrossTab
    lRightColumns = rngRightHeaders.Columns.Count
    lLeftColumns = UBound(varSource, 2) - lRightColumns
   
    ReDim varOutput(1 To lRightColumns * (UBound(varSource) - 1), 1 To lLeftColumns + 2)
   
    For j = 1 To UBound(varOutput)
        m = (j - 1) Mod (UBound(varSource) - 1) + 2
        n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1
        varOutput(j, lLeftColumns + 1) = varSource(1, n)
        varOutput(j, lLeftColumns + 2) = varSource(m, n)
        For i = 1 To lLeftColumns
            varOutput(j, i) = varSource(m, i)
        Next i
    Next j
   
    Worksheets.Add

    With Cells(1, 1)
        .Resize(, lLeftColumns).Value = rngLeftHeaders.Value
        .Offset(, lLeftColumns).Value = strCrosstabName
        .Offset(, lLeftColumns + 1).Value = "Value"
        .Offset(1, 0).Resize(UBound(varOutput), UBound(varOutput, 2)) = varOutput
    End With
    
    
timetaken = timetaken - Now()
    
    Debug.Print "UnPivot - snb: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")
errhandler:
    If Err.Number <> 0 Then
        Dim strErrMsg As String
        Select Case Err.Number
        Case 999: 'User pushed cancel. Do nothing
        Case 998   'Worksheet does not have enough rows to hold flat file
            strErrMsg = "Oops, there's not enough rows in the worsheet to hold a flatfile of all the data you have selected. "
            strErrMsg = strErrMsg & vbNewLine & vbNewLine
            strErrMsg = strErrMsg & "Your dataset will take up " & Format(rngRightHeaders.CurrentRegion.Count, "#,##0") & " rows of data "
            strErrMsg = strErrMsg & "but your worksheet only allows " & Format(Application.Range("A:A").Count, "#,##0") & " rows of data. "
            strErrMsg = strErrMsg & vbNewLine & vbNewLine
            MsgBox strErrMsg

        Case Else
            MsgBox Err.Description, vbCritical, "UnPivot_snb"

        End Select

    End If
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

Sub UnPivot_snb()

Dim varSource As Variant

Dim j As Long

Dim m As Long

Dim n As Long

Dim i As Long

Dim varOutput As Variant

Dim rngCrossTab As Range

Dim rngLeftHeaders As Range

Dim rngRightHeaders As Range

'Identify where the ENTIRE crosstab table is

If rngCrossTab Is Nothing Then

On Error Resume Next

Set rngCrossTab = Application.InputBox( _

Title:="Please select the ENTIRE crosstab", _

prompt:="Please select the ENTIRE crosstab that you want to turn into a flat file", _

Type:=8, Default:=Selection.CurrentRegion.Address)

If Err.Number <> 0 Then

On Error GoTo errhandler

Err.Raise 999

Else: On Error GoTo errhandler

End If

rngCrossTab.Parent.Activate

rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience

End If

'Identify range containing columns of interest running down the table

If rngLeftHeaders Is Nothing Then

On Error Resume Next

Set rngLeftHeaders = Application.InputBox( _

Title:="Select the column HEADERS from the LEFT of the table that WON'T be aggregated", _

prompt:="Select the column HEADERS from the LEFT of the table that won't be aggregated", _

Default:=Selection.Address, Type:=8)

If Err.Number <> 0 Then

On Error GoTo errhandler

Err.Raise 999

Else: On Error GoTo errhandler

End If

Set rngLeftHeaders = rngLeftHeaders.Resize(1, rngLeftHeaders.Columns.Count) 'just in case they selected the entire column

rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1).Select 'Returns them to the right of the range they just selected

End If

If rngRightHeaders Is Nothing Then

'Identify range containing data and cross-tab headers running across the table

On Error Resume Next

Set rngRightHeaders = Application.InputBox( _

Title:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _

prompt:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _

Default:=Selection.Address, _

Type:=8)

If Err.Number <> 0 Then

On Error GoTo errhandler

Err.Raise 999

Else: On Error GoTo errhandler

End If

Set rngRightHeaders = rngRightHeaders.Resize(1, rngRightHeaders.Columns.Count) 'just in case they selected the entire column

rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience

End If

If strCrosstabName = "" Then

'Get the field name for the columns being consolidated e.g. 'Country' or 'Project'. note that reserved SQL words like 'Date' cannot be used

strCrosstabName = Application.InputBox( _

Title:="What name do you want to give the data field being aggregated?", _

prompt:="What name do you want to give the data field being aggregated? e.g. 'Date', 'Country', etc.", _

Default:="Date", _

Type:=2)

If strCrosstabName = "False" Then Err.Raise 999

End If

timetaken = Now()

varSource = rngCrossTab

lRightColumns = rngRightHeaders.Columns.Count

lLeftColumns = UBound(varSource, 2) - lRightColumns

ReDim varOutput(1 To lRightColumns * (UBound(varSource) - 1), 1 To lLeftColumns + 2)

For j = 1 To UBound(varOutput)

m = (j - 1) Mod (UBound(varSource) - 1) + 2

n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1

varOutput(j, lLeftColumns + 1) = varSource(1, n)

varOutput(j, lLeftColumns + 2) = varSource(m, n)

For i = 1 To lLeftColumns

varOutput(j, i) = varSource(m, i)

Next i

Next j

Worksheets.Add

With Cells(1, 1)

.Resize(, lLeftColumns).Value = rngLeftHeaders.Value

.Offset(, lLeftColumns).Value = strCrosstabName

.Offset(, lLeftColumns + 1).Value = "Value"

.Offset(1, 0).Resize(UBound(varOutput), UBound(varOutput, 2)) = varOutput

End With

timetaken = timetaken - Now()

Debug.Print "UnPivot - snb: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")

errhandler:

If Err.Number <> 0 Then

Dim strErrMsg As String

Select Case Err.Number

Case 999: 'User pushed cancel. Do nothing

Case 998 'Worksheet does not have enough rows to hold flat file

strErrMsg = "Oops, there's not enough rows in the worsheet to hold a flatfile of all the data you have selected. "

strErrMsg = strErrMsg & vbNewLine & vbNewLine

strErrMsg = strErrMsg & "Your dataset will take up " & Format(rngRightHeaders.CurrentRegion.Count, "#,##0") & " rows of data "

strErrMsg = strErrMsg & "but your worksheet only allows " & Format(Application.Range("A:A").Count, "#,##0") & " rows of data. "

strErrMsg = strErrMsg & vbNewLine & vbNewLine

MsgBox strErrMsg

Case Else

MsgBox Err.Description, vbCritical, "UnPivot_snb"

End Select

End If

End Sub

Talk about yo-yo dieting!

Multiple Consolidation Trick approach

And here’s my code that uses the Multiple Consolidation trick:

Option Explicit

Sub CallUnPivotByConsolidation()
Call UnPivotByConsolidation
End Sub

Function UnPivotByConsolidation( _
                      Optional rngCrossTab As Range, _
                      Optional rngLeftHeaders As Range, _
                      Optional rngRightHeaders As Range, _
                      Optional strCrosstabName As String) As Boolean

    Dim wksTempCrosstab As Worksheet
    Dim wksInitial As Worksheet
    Dim strConcat As String
    Dim strCell As String
    Dim strFormula As String
    Dim iCount As Integer
    Dim iColumns As Integer
    Dim iRows As Integer
    Dim rngInputData As Range
    Dim wksPT As Worksheet
    Dim wksFlatFile As Worksheet
    Dim pc As PivotCache
    Dim pt As PivotTable
    Dim rngKeyFormula As Range
    Dim rngRowHeaders As Range
    Dim rngPT_GrandTotal As Range, rngPTData As Range
    Dim lPT_Rows As Long
    Dim iPT_Columns As Integer
    Dim iKeyColumns As Integer
    Dim varRowHeadings  As Variant


    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Part one:                                                                  '
    'Code prompts user to select contiguous or non-contiguous columns of data   '
    'from a crosstab table, and writes it to a new sheet in a contiguous range. '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Set wksInitial = ActiveSheet


'Identify where the ENTIRE crosstab table is
    If rngCrossTab Is Nothing Then
        On Error Resume Next
        Set rngCrossTab = Application.InputBox( _
                          Title:="Please select the ENTIRE crosstab", _
                          prompt:="Please select the ENTIRE crosstab that you want to turn into a flat file", _
                          Type:=8, Default:=Selection.CurrentRegion.Address)
        If Err.Number <> 0 Then
            On Error GoTo errhandler
            Err.Raise 999
        Else: On Error GoTo errhandler
        End If
        rngCrossTab.Parent.Activate
        rngCrossTab.Cells(1, 1).Select    'Returns them to the top left of the source table for convenience
    End If


'Identify range containing columns of interest running down the table
    If rngLeftHeaders Is Nothing Then
        On Error Resume Next
        Set rngLeftHeaders = Application.InputBox( _
                             Title:="Select the column HEADERS from the LEFT of the table that WON'T be aggregated", _
                             prompt:="Select the column HEADERS from the LEFT of the table that won't be aggregated", _
                             Default:=Selection.Address, Type:=8)
        If Err.Number <> 0 Then
            On Error GoTo errhandler
            Err.Raise 999
        Else: On Error GoTo errhandler
        End If
        Set rngLeftHeaders = Intersect(rngLeftHeaders.EntireColumn, rngCrossTab)
        rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1).Select    'Returns them to the right of the range they just selected
    End If
    
    If rngRightHeaders Is Nothing Then
        'Identify range containing data and cross-tab headers running across the table
        On Error Resume Next
        Set rngRightHeaders = Application.InputBox( _
                              Title:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
                              prompt:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
                              Default:=Selection.Address, _
                              Type:=8)
         If Err.Number <> 0 Then
            On Error GoTo errhandler
            Err.Raise 999
        Else: On Error GoTo errhandler
        End If
        Set rngRightHeaders = Intersect(rngRightHeaders.EntireColumn, rngCrossTab)
        rngCrossTab.Cells(1, 1).Select    'Returns them to the top left of the source table for convenience
    End If

    If strCrosstabName = "" Then
        'Get the field name for the columns being consolidated e.g. 'Country' or 'Project'. note that reserved SQL words like 'Date' cannot be used
        strCrosstabName = Application.InputBox( _
                          Title:="What name do you want to give the data field being aggregated?", _
                          prompt:="What name do you want to give the data field being aggregated? e.g. 'Date', 'Country', etc.", _
                          Default:="Date", _
                          Type:=2)
         If strCrosstabName = "False" Then Err.Raise 999
    End If
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
     'Set up a temp worksheet to house our crosstab data
    For Each wksTempCrosstab In ActiveWorkbook.Worksheets
        If wksTempCrosstab.Name = "TempCrosstab" Then wksTempCrosstab.Delete
    Next
    Set wksTempCrosstab = Worksheets.Add
    wksTempCrosstab.Name = "TempCrosstab"

    'Copy data to the temp worksheet "TempCrosstab"
    rngLeftHeaders.Copy wksTempCrosstab.[A1]
    Set rngLeftHeaders = wksTempCrosstab.[A1].CurrentRegion
    rngLeftHeaders.Name = "TempCrosstab!appRowFields"
    rngRightHeaders.Copy wksTempCrosstab.[A1].Offset(0, rngLeftHeaders.Columns.Count)
    Set rngRightHeaders = wksTempCrosstab.[A1].Resize(rngRightHeaders.Rows.Count, rngRightHeaders.Columns.Count)
    rngRightHeaders.Name = "TempCrosstab!appCrosstabFields"

    'Work out if the worksheet has enough rows to fit a crosstab in
    If rngRightHeaders.CurrentRegion.Count > Columns(1).Rows.Count Then Err.Raise 998

    varRowHeadings = rngLeftHeaders.Value

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Part Two:                                                                  '
    'Construct a new pipe-delimited column out of the columns that run down the '
    'left of the crosstab, and then delete the original columns used to do this '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    strFormula = "=RC[1]"
    strConcat = "&""|""&"

    iColumns = Range("TempCrosstab!appRowFields").Columns.Count

    For iCount = 2 To iColumns
        strCell = "RC[" & iCount & "]"
        strFormula = strFormula & strConcat & strCell
    Next iCount

    With Worksheets("TempCrosstab")
        .Columns("A:A").Insert Shift:=xlToRight
        iRows = Intersect(Worksheets("TempCrosstab").Columns(2), Worksheets("TempCrosstab").UsedRange).Rows.Count
        .Range("A2:A" & iRows).FormulaR1C1 = strFormula
        .Range("A2:A" & iRows).Value = .Range("A2:A" & iRows).Value
        .Range("appRowFields").Delete Shift:=xlToLeft
    End With

    Names("TempCrosstab!appRowFields").Delete

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Part Three:                                                                    '
    'Use data to create a pivot table using "Multiple Consolidation Ranges" option, '
    'which has the side benefit of providing a vertical extract once you double     '
    'click on the Grand Total field                                                 '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set rngInputData = Worksheets("TempCrosstab").[A2].CurrentRegion
    rngInputData.Name = "SourceData"

    'Find out the number of columns contained within the primary key
    iKeyColumns = Len([SourceData].Cells(2, 1).Value) - Len(Replace([SourceData].Cells(2, 1).Value, "|", "")) + 1

    '   Create the intermediate pivot from which to extract flat file
    Set pc = ActiveWorkbook.PivotCaches.Add(SourceType:=xlConsolidation, SourceData:=Array("=sourcedata", "Item1"))
    Set wksPT = Worksheets.Add
    Set pt = wksPT.PivotTables.Add(PivotCache:=pc, TableDestination:=[A3])


    '   Get address of PT Total field, then double click it to get underlying records
    Set rngPTData = pt.DataBodyRange
    lPT_Rows = rngPTData.Rows.Count
    iPT_Columns = rngPTData.Columns.Count
    Set rngPT_GrandTotal = rngPTData.Cells(1).Offset(lPT_Rows - 1, iPT_Columns - 1)
    rngPTData.Cells(1).Offset(lPT_Rows - 1, iPT_Columns - 1).Select
    Selection.ShowDetail = True
    Set wksFlatFile = ActiveSheet

    '   Delete current "Flat_File" worksheet if it exists, name current sheet "Flat_File"
    On Error Resume Next
    Sheets("Flat_File").Delete
    On Error GoTo 0
    wksFlatFile.Name = "Flat_File"

    '   Delete unneeded column and the now-unneeded TempCrosstab and wksPT worksheets
    Columns(4).Delete Shift:=xlToLeft
    wksPT.Delete
    Worksheets("TempCrosstab").Delete

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Part Four:                                                                '
    'split our pipe-delimited column back into seperate columns, using Excel's '
    'Text-to-Column funcionality.                                              '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Set rngKeyFormula = Worksheets("Flat_File").Range("A2")
    rngKeyFormula.Name = "appKeyFormula"

    'Find out the number of columns contained within the primary key
    iKeyColumns = Len([appKeyFormula].Cells(2, 1).Value) - Len(Replace([appKeyFormula].Cells(2, 1).Value, "|", "")) + 1

    'Insert columns to the left that we will unpack the Unique Key to
    [B1].Resize(, iKeyColumns).EntireColumn.Insert


    'Split the Unique Key column into its constituent parts,
    'using Excel's Text-to-Columns functionality
    Worksheets("Flat_File").Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("b1"), DataType:=xlDelimited, _
                            ConsecutiveDelimiter:=False, Other:=True, OtherChar:="|"

    'Delete old composite key, add original column headers
    [A1].EntireColumn.Delete
    Set rngRowHeaders = [A1].Resize(1, iKeyColumns)
    rngRowHeaders.Value = varRowHeadings

    'Add new column header with crosstab data name
    [A1].Offset(0, iKeyColumns).Value = strCrosstabName
    Selection.CurrentRegion.Columns.AutoFit
    
    Worksheets("Flat_File").Select

errhandler:
    If Err.Number <> 0 Then
        Dim strErrMsg As String
        Select Case Err.Number
        Case 999: 'User pushed cancel. Do nothing
        Case 998   'Worksheet does not have enough rows to hold flat file
            strErrMsg = "Oops, there's not enough rows in the worsheet to hold a flatfile of all the data you have selected. "
            strErrMsg = strErrMsg & vbNewLine & vbNewLine
            strErrMsg = strErrMsg & "Your dataset will take up " & Format(rngRightHeaders.CurrentRegion.Count, "#,##0") & " rows of data "
            strErrMsg = strErrMsg & "but your worksheet only allows " & Format(Application.Range("A:A").Count, "#,##0") & " rows of data. "
            strErrMsg = strErrMsg & vbNewLine & vbNewLine
            MsgBox strErrMsg

        Case Else
            MsgBox Err.Description, vbCritical, "UnPivotByConsolidation"

        End Select

    End If

With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

Option Explicit

Sub CallUnPivotByConsolidation()

Call UnPivotByConsolidation

End Sub

Function UnPivotByConsolidation( _

Optional rngCrossTab As Range, _

Optional rngLeftHeaders As Range, _

Optional rngRightHeaders As Range, _

Optional strCrosstabName As String) As Boolean

Dim wksTempCrosstab As Worksheet

Dim wksInitial As Worksheet

Dim strConcat As String

Dim strCell As String

Dim strFormula As String

Dim iCount As Integer

Dim iColumns As Integer

Dim iRows As Integer

Dim rngInputData As Range

Dim wksPT As Worksheet

Dim wksFlatFile As Worksheet

Dim pc As PivotCache

Dim pt As PivotTable

Dim rngKeyFormula As Range

Dim rngRowHeaders As Range

Dim rngPT_GrandTotal As Range, rngPTData As Range

Dim lPT_Rows As Long

Dim iPT_Columns As Integer

Dim iKeyColumns As Integer

Dim varRowHeadings As Variant

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Part one: '

'Code prompts user to select contiguous or non-contiguous columns of data '

'from a crosstab table, and writes it to a new sheet in a contiguous range. '

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Set wksInitial = ActiveSheet

'Identify where the ENTIRE crosstab table is

If rngCrossTab Is Nothing Then

On Error Resume Next

Set rngCrossTab = Application.InputBox( _

Title:="Please select the ENTIRE crosstab", _

prompt:="Please select the ENTIRE crosstab that you want to turn into a flat file", _

Type:=8, Default:=Selection.CurrentRegion.Address)

If Err.Number <> 0 Then

On Error GoTo errhandler

Err.Raise 999

Else: On Error GoTo errhandler

End If

rngCrossTab.Parent.Activate

rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience

End If

'Identify range containing columns of interest running down the table

If rngLeftHeaders Is Nothing Then

On Error Resume Next

Set rngLeftHeaders = Application.InputBox( _

Title:="Select the column HEADERS from the LEFT of the table that WON'T be aggregated", _

prompt:="Select the column HEADERS from the LEFT of the table that won't be aggregated", _

Default:=Selection.Address, Type:=8)

If Err.Number <> 0 Then

On Error GoTo errhandler

Err.Raise 999

Else: On Error GoTo errhandler

End If

Set rngLeftHeaders = Intersect(rngLeftHeaders.EntireColumn, rngCrossTab)

rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1).Select 'Returns them to the right of the range they just selected

End If

If rngRightHeaders Is Nothing Then

'Identify range containing data and cross-tab headers running across the table

On Error Resume Next

Set rngRightHeaders = Application.InputBox( _

Title:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _

prompt:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _

Default:=Selection.Address, _

Type:=8)

If Err.Number <> 0 Then

On Error GoTo errhandler

Err.Raise 999

Else: On Error GoTo errhandler

End If

Set rngRightHeaders = Intersect(rngRightHeaders.EntireColumn, rngCrossTab)

rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience

End If

If strCrosstabName = "" Then

'Get the field name for the columns being consolidated e.g. 'Country' or 'Project'. note that reserved SQL words like 'Date' cannot be used

strCrosstabName = Application.InputBox( _

Title:="What name do you want to give the data field being aggregated?", _

prompt:="What name do you want to give the data field being aggregated? e.g. 'Date', 'Country', etc.", _

Default:="Date", _

Type:=2)

If strCrosstabName = "False" Then Err.Raise 999

End If

With Application

.ScreenUpdating = False

.DisplayAlerts = False

End With

'Set up a temp worksheet to house our crosstab data

For Each wksTempCrosstab In ActiveWorkbook.Worksheets

If wksTempCrosstab.Name = "TempCrosstab" Then wksTempCrosstab.Delete

Set wksTempCrosstab = Worksheets.Add

wksTempCrosstab.Name = "TempCrosstab"

'Copy data to the temp worksheet "TempCrosstab"

rngLeftHeaders.Copy wksTempCrosstab.[A1]

Set rngLeftHeaders = wksTempCrosstab.[A1].CurrentRegion

rngLeftHeaders.Name = "TempCrosstab!appRowFields"

rngRightHeaders.Copy wksTempCrosstab.[A1].Offset(0, rngLeftHeaders.Columns.Count)

Set rngRightHeaders = wksTempCrosstab.[A1].Resize(rngRightHeaders.Rows.Count, rngRightHeaders.Columns.Count)

rngRightHeaders.Name = "TempCrosstab!appCrosstabFields"

'Work out if the worksheet has enough rows to fit a crosstab in

If rngRightHeaders.CurrentRegion.Count > Columns(1).Rows.Count Then Err.Raise 998

varRowHeadings = rngLeftHeaders.Value

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Part Two: '

'Construct a new pipe-delimited column out of the columns that run down the '

'left of the crosstab, and then delete the original columns used to do this '

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

strFormula = "=RC[1]"

strConcat = "&""|""&"

iColumns = Range("TempCrosstab!appRowFields").Columns.Count

For iCount = 2 To iColumns

strCell = "RC[" & iCount & "]"

strFormula = strFormula & strConcat & strCell

Next iCount

With Worksheets("TempCrosstab")

.Columns("A:A").Insert Shift:=xlToRight

iRows = Intersect(Worksheets("TempCrosstab").Columns(2), Worksheets("TempCrosstab").UsedRange).Rows.Count

.Range("A2:A" & iRows).FormulaR1C1 = strFormula

.Range("A2:A" & iRows).Value = .Range("A2:A" & iRows).Value

.Range("appRowFields").Delete Shift:=xlToLeft

End With

Names("TempCrosstab!appRowFields").Delete

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Part Three: '

'Use data to create a pivot table using "Multiple Consolidation Ranges" option, '

'which has the side benefit of providing a vertical extract once you double '

'click on the Grand Total field '

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Set rngInputData = Worksheets("TempCrosstab").[A2].CurrentRegion

rngInputData.Name = "SourceData"

'Find out the number of columns contained within the primary key

iKeyColumns = Len([SourceData].Cells(2, 1).Value) - Len(Replace([SourceData].Cells(2, 1).Value, "|", "")) + 1

' Create the intermediate pivot from which to extract flat file

Set pc = ActiveWorkbook.PivotCaches.Add(SourceType:=xlConsolidation, SourceData:=Array("=sourcedata", "Item1"))

Set wksPT = Worksheets.Add

Set pt = wksPT.PivotTables.Add(PivotCache:=pc, TableDestination:=[A3])

' Get address of PT Total field, then double click it to get underlying records

Set rngPTData = pt.DataBodyRange

lPT_Rows = rngPTData.Rows.Count

iPT_Columns = rngPTData.Columns.Count

Set rngPT_GrandTotal = rngPTData.Cells(1).Offset(lPT_Rows - 1, iPT_Columns - 1)

rngPTData.Cells(1).Offset(lPT_Rows - 1, iPT_Columns - 1).Select

Selection.ShowDetail = True

Set wksFlatFile = ActiveSheet

' Delete current "Flat_File" worksheet if it exists, name current sheet "Flat_File"

On Error Resume Next

Sheets("Flat_File").Delete

On Error GoTo 0

wksFlatFile.Name = "Flat_File"

' Delete unneeded column and the now-unneeded TempCrosstab and wksPT worksheets

Columns(4).Delete Shift:=xlToLeft

wksPT.Delete

Worksheets("TempCrosstab").Delete

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Part Four: '

'split our pipe-delimited column back into seperate columns, using Excel's '

'Text-to-Column funcionality. '

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Set rngKeyFormula = Worksheets("Flat_File").Range("A2")

rngKeyFormula.Name = "appKeyFormula"

'Find out the number of columns contained within the primary key

iKeyColumns = Len([appKeyFormula].Cells(2, 1).Value) - Len(Replace([appKeyFormula].Cells(2, 1).Value, "|", "")) + 1

'Insert columns to the left that we will unpack the Unique Key to

[B1].Resize(, iKeyColumns).EntireColumn.Insert

'Split the Unique Key column into its constituent parts,

'using Excel's Text-to-Columns functionality

Worksheets("Flat_File").Columns("A:A").Select

Selection.TextToColumns Destination:=Range("b1"), DataType:=xlDelimited, _

ConsecutiveDelimiter:=False, Other:=True, OtherChar:="|"

'Delete old composite key, add original column headers

[A1].EntireColumn.Delete

Set rngRowHeaders = [A1].Resize(1, iKeyColumns)

rngRowHeaders.Value = varRowHeadings

'Add new column header with crosstab data name

[A1].Offset(0, iKeyColumns).Value = strCrosstabName

Selection.CurrentRegion.Columns.AutoFit

Worksheets("Flat_File").Select

errhandler:

If Err.Number <> 0 Then

Dim strErrMsg As String

Select Case Err.Number

Case 999: 'User pushed cancel. Do nothing

Case 998 'Worksheet does not have enough rows to hold flat file

strErrMsg = "Oops, there's not enough rows in the worsheet to hold a flatfile of all the data you have selected. "

strErrMsg = strErrMsg & vbNewLine & vbNewLine

strErrMsg = strErrMsg & "Your dataset will take up " & Format(rngRightHeaders.CurrentRegion.Count, "#,##0") & " rows of data "

strErrMsg = strErrMsg & "but your worksheet only allows " & Format(Application.Range("A:A").Count, "#,##0") & " rows of data. "

strErrMsg = strErrMsg & vbNewLine & vbNewLine

MsgBox strErrMsg

Case Else

MsgBox Err.Description, vbCritical, "UnPivotByConsolidation"

End Select

End If

With Application

.ScreenUpdating = True

.DisplayAlerts = True

End With

End Function

The SQL appoach is the same as I published here.

And the winner is…

…snb. By a long shot. With the ever-so-slight caveat that you’re crosstabs are not so stupidly fat that the resulting flat file exceeds the number of rows in Excel.

Here’s how things stacked up on a 53 Column x 2146 Row crosstab, which gives a 117,738 row flat-file:

Approach	Time (M:SS)
snb	0:01
UnPivotByConsolidation	0:04
UnPivotBySQL	0:14

And here’s how things stacked up on a 53 Columns x 19,780 Row crosstab, giving a 1,048,340 row flat-file (i.e. practically the biggest sized crosstab that you can unwind):

Approach	Time (M:SS)
snb	0:19
UnPivotByConsolidation	0:42
UnPivotBySQL	2:17

So there you have it. Use snb’s code. Unless you have no choice but to use my longer, slower SQL approach.

—Update 26 November 2013—
It was remiss of me not to mention the Data Normalizer routine in Doug Glancy’s great yoursumbuddy blog, which is just about as fast as snb’s approach below. Go check it out, and subscribe to Doug’s blog while you’re there if you haven’t already.
—

If you don’t want the hassle of working out which to use, here’s a routine that uses snb’s if possible, and otherwise uses mine:

Option Explicit
Sub Call_UnPivot()
UnPivot
End Sub


Function unpivot(Optional rngCrossTab As Range, _
                      Optional rngLeftHeaders As Range, _
                      Optional rngRightHeaders As Range, _
                      Optional strCrosstabName As String, _
                      Optional rngOutput As Range, _
                      Optional bSkipBlanks As Boolean = False) As Boolean

'   Desc:   Turns a crosstab file into a flatfile using array manipulation.
'           If the resulting flat file will be too long to fit in the worksheet,
'           the routine uses SQL and lots of 'UNION ALL' statements to do the
'           equivalent of the 'UNPfaddIVOT' command in SQL Server (which is not available
'           in Excel)and writes the result directly to a PivotTable

'           Base code for the SQL UnPivot derived from from Fazza at MR EXCEL forum:
'           http://www.mrexcel.com/forum/showthread.php?315768-Creating-a-pivot-table-with-multiple-sheets
'           The Microsoft JET/ACE Database engine has a hard limit of 50 'UNION ALL' clauses, but Fazza's
'           code gets around this by creating sublocks of up to 25 SELECT/UNION ALL statements, and
'           then unioning these.


'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com

'   Name/Version:    Date:      Ini:    Modification:
'   UnPivot V1      20131122    JSW     Original Development
   
'   Inputs:         Range of the entile crosstab
'                   Range of columns down the left that WON'T be normalized
'                   Range of columns down the right that WILL be normalize
'                   String containing the name to give columns that will be normalized

'   Outputs:        A pivottable of the input data on a new worksheet.

'   Example:

'   It takes a crosstabulated table that looks like this:

'   Country        Sector          1990        1991        ...         2009
'   =============================================================================
'   Australia      Energy          290,872     296,887     ...         417,355
'   New Zealand    Energy          23,915      25,738      ...         31,361
'   United States  Energy          5,254,607   5,357,253   ...         5,751,106
'   Australia      Manufacturing   35,648      35,207      ...         44,514
'   New Zealand    Manufacturing   4,389       4,845       ...         4,907
'   United States  Manufacturing   852,424     837,828     ...         735,902
'   Australia      Transport       62,121      61,504      ...         83,645
'   New Zealand    Transport       8,679       8,696       ...         13,783
'   United States  Transport       1,484,909   1,447,234   ...         1,722,501



'   And it returns the same data in a recordset organised like this:

'   Country        Sector          Year        Value
'   ====================================================
'   Australia      Energy          1990        290,872
'   New Zealand    Energy          1990        23,915
'   United States  Energy          1990        5,254,607
'   Australia      Manufacturing   1990        35,648
'   New Zealand    Manufacturing   1990        4,389
'   United States  Manufacturing   1990        852,424
'   Australia      Transport       1990        62,121
'   New Zealand    Transport       1990        8,679
'   United States  Transport       1990        1,484,909
'   Australia      Energy          1991        296,887
'   New Zealand    Energy          1991        25,738
'   United States  Energy          1991        5,357,253
'   Australia      Manufacturing   1991        35,207
'   New Zealand    Manufacturing   1991        4,845
'   United States  Manufacturing   1991        837,828
'   Australia      Transport       1991        61,504
'   New Zealand    Transport       1991        8,696
'   United States  Transport       1991        1,447,234
'   ...            ...             ...         ...
'   ...            ...             ...         ...
'   ...            ...             ...         ...
'   Australia      Energy          2009        417,355
'   New Zealand    Energy          2009        31,361
'   United States  Energy          2009        5,751,106
'   Australia      Manufacturing   2009        44,514
'   New Zealand    Manufacturing   2009        4,907
'   United States  Manufacturing   2009        735,902
'   Australia      Transport       2009        83,645
'   New Zealand    Transport       2009        13,783
'   United States  Transport       2009        1,722,501


    Const lngMAX_UNIONS As Long = 25

    Dim varSource As Variant
    Dim varOutput As Variant
    Dim lLeftColumns As Long
    Dim lRightColumns As Long
    Dim i As Long
    Dim j As Long
    Dim m As Long
    Dim n As Long
    Dim lOutputRows As Long
    Dim arSQL() As String
    Dim arTemp() As String
    Dim sTempFilePath As String
    Dim objPivotCache As PivotCache
    Dim objRS As Object
    Dim oConn As Object
    Dim sConnection As String
    Dim wks As Worksheet
    Dim wksNew As Worksheet
    Dim cell As Range
    Dim strLeftHeaders As String
    Dim wksSource As Worksheet
    Dim pt As PivotTable
    Dim rngCurrentHeader As Range
    Dim timetaken As Date
    Dim strMsg As String
    Dim varAnswer As Variant

    Const Success As Boolean = True
    Const Failure As Boolean = False

    unpivot = Failure

    
    'Identify where the ENTIRE crosstab table is
    If rngCrossTab Is Nothing Then
        Application.ScreenUpdating = True
        On Error Resume Next
        Set rngCrossTab = Application.InputBox( _
                          Title:="Please select the ENTIRE crosstab", _
                          Prompt:="Please select the ENTIRE crosstab that you want to turn into a flat file", _
                          Type:=8, Default:=Selection.CurrentRegion.Address)
        If Err.Number <> 0 Then
            On Error GoTo ErrHandler
            Err.Raise 999
        Else: On Error GoTo ErrHandler
        End If
        rngCrossTab.Parent.Activate
        rngCrossTab.Cells(1, 1).Select    'Returns them to the top left of the source table for convenience
    End If

    'Identify range containing columns of interest running down the table
    If rngLeftHeaders Is Nothing Then
        On Error Resume Next
        Set rngLeftHeaders = Application.InputBox( _
                             Title:="Select the column HEADERS from the LEFT of the table that WON'T be aggregated", _
                             Prompt:="Select the column HEADERS from the LEFT of the table that won't be aggregated", _
                             Default:=Selection.Address, Type:=8)
        If Err.Number <> 0 Then
            On Error GoTo ErrHandler
            Err.Raise 999
        Else: On Error GoTo ErrHandler
        End If
        Set rngLeftHeaders = rngLeftHeaders.Resize(1, rngLeftHeaders.Columns.Count)    'just in case they selected the entire column
        Range(rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1), rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1).End(xlToRight)).Select   'Returns them to the right of the range they just selected
    End If


    If rngRightHeaders Is Nothing Then
        'Identify range containing data and cross-tab headers running across the table
        On Error Resume Next
        Set rngRightHeaders = Application.InputBox( _
                              Title:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
                              Prompt:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
                              Default:=Selection.Address, _
                              Type:=8)
         If Err.Number <> 0 Then
            On Error GoTo ErrHandler
            Err.Raise 999
        Else: On Error GoTo ErrHandler
        End If
        Set rngRightHeaders = rngRightHeaders.Resize(1, rngRightHeaders.Columns.Count)    'just in case they selected the entire column
        rngCrossTab.Cells(1, 1).Select    'Returns them to the top left of the source table for convenience
    End If


    If strCrosstabName = "" Then
        'Get the field name for the columns being consolidated e.g. 'Country' or 'Project'. note that reserved SQL words like 'Date' cannot be used
        strCrosstabName = Application.InputBox( _
                          Title:="What name do you want to give the data field being aggregated?", _
                          Prompt:="What name do you want to give the data field being aggregated? e.g. 'Date', 'Country', etc.", _
                          Default:="Date", _
                          Type:=2)
         If strCrosstabName = "False" Then Err.Raise 999
    End If

    If rngOutput Is Nothing Then
        'Identify range containing data and cross-tab headers running across the table
        On Error Resume Next
        Set rngOutput = Application.InputBox( _
                              Title:="Where do you want to output the data", _
                              Prompt:="Select the top left cell where you want the transformed data to be output", _
                              Default:=Cells(ActiveSheet.UsedRange.row, ActiveSheet.UsedRange.Columns.Count + ActiveSheet.UsedRange.Column + 1).Address, _
                              Type:=8)
         If Err.Number <> 0 Then
            On Error GoTo ErrHandler
            Err.Raise 999
        Else: On Error GoTo ErrHandler
        End If
    End If



    timetaken = Now()
    Application.ScreenUpdating = False
       
    'Work out if the worksheet has enough rows to fit a crosstab in
    If Intersect(rngRightHeaders.EntireColumn, rngCrossTab).Cells.Count <= Columns(1).Rows.Count Then
        'Resulting flat file will fit on the sheet, so use array manipulation.
        varSource = rngCrossTab
        lRightColumns = rngRightHeaders.Columns.Count
        lLeftColumns = UBound(varSource, 2) - lRightColumns
        
        If Not bSkipBlanks Then
            ReDim varOutput(1 To lRightColumns * (UBound(varSource) - 1), 1 To lLeftColumns + 2)
        Else
            lOutputRows = Application.WorksheetFunction.CountA(Intersect([appRightHeaders].EntireColumn, rngCrossTab)) - [appRightHeaders].Cells.Count
            ReDim varOutput(1 To lOutputRows, 1 To lLeftColumns + 2)
        End If

        If Not bSkipBlanks Then
            For j = 1 To UBound(varOutput)
                m = (j - 1) Mod (UBound(varSource) - 1) + 2
                n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1
                varOutput(j, lLeftColumns + 1) = varSource(1, n)
                varOutput(j, lLeftColumns + 2) = varSource(m, n)
                For i = 1 To lLeftColumns
                    varOutput(j, i) = varSource(m, i)
                Next i
            Next j
        Else
            lOutputRows = 1
            For j = 1 To Intersect([appRightHeaders].EntireColumn, rngCrossTab).Cells.Count - [appRightHeaders].Cells.Count
                m = (j - 1) Mod (UBound(varSource) - 1) + 2
                n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1
                If Not IsEmpty(varSource(m, n)) Then
                    varOutput(lOutputRows, lLeftColumns + 1) = varSource(1, n)
                    varOutput(lOutputRows, lLeftColumns + 2) = varSource(m, n)
                    For i = 1 To lLeftColumns
                        varOutput(lOutputRows, i) = varSource(m, i)
                    Next i
                    lOutputRows = lOutputRows + 1
                End If
            Next j
            
            End If
       

   
        With rngOutput
            .Resize(, lLeftColumns).Value = rngLeftHeaders.Value
            .Offset(, lLeftColumns).Value = strCrosstabName
            .Offset(, lLeftColumns + 1).Value = "Quantity"
            .Offset(1, 0).Resize(UBound(varOutput), UBound(varOutput, 2)) = varOutput
        End With
           
    Else 'Resulting flat file will fit on the sheet, so use SQL and write result directly to a pivot
        strMsg = " I can't turn this crosstab into a flat file, because the crosstab is so large that"
        strMsg = strMsg & " the resulting flat file will be too big to fit in a worksheet. "
        strMsg = strMsg & vbNewLine & vbNewLine
        strMsg = strMsg & " However, I can still turn this information directly into a PivotTable if you want."
        strMsg = strMsg & " Note that this might take several minutes. Do you wish to proceed?"
        varAnswer = MsgBox(Prompt:=strMsg, Buttons:=vbOK + vbCancel + vbCritical, Title:="Crosstab too large!")
        If varAnswer <> 6 Then Err.Raise 999

        If ActiveWorkbook.Path <> "" Then    'can only proceed if the workbook has been saved somewhere
            Set wksSource = rngLeftHeaders.Parent
   
            'Build part of SQL Statement that deals with 'static' columns i.e. the ones down the left
            For Each cell In rngLeftHeaders
           
                'For some reason this approach doesn't like columns with numeric headers.
                ' My solution in the below line is to prefix any numeric characters with
                ' an apostrophe to render them non-numeric, and restore them back to numeric
                ' after the query has run
               
                If IsNumeric(cell) Or IsDate(cell) Then cell.Value = "'" & cell.Value
                strLeftHeaders = strLeftHeaders & "[" & cell.Value & "], "
               
            Next cell
   
            ReDim arTemp(1 To lngMAX_UNIONS)    'currently 25 as per declaration at top of module
   
            ReDim arSQL(1 To (rngRightHeaders.Count - 1) \ lngMAX_UNIONS + 1)
   
            For i = LBound(arSQL) To UBound(arSQL) - 1
                For j = LBound(arTemp) To UBound(arTemp)
                    Set rngCurrentHeader = rngRightHeaders(1, (i - 1) * lngMAX_UNIONS + j)
   
                    arTemp(j) = "SELECT " & strLeftHeaders & "[" & rngCurrentHeader.Value & "] AS Total, '" & rngCurrentHeader.Value & "' AS [" & strCrosstabName & "] FROM [" & rngCurrentHeader.Parent.Name & "$" & Replace(rngCrossTab.Address, "$", "") & "]"
                    If IsNumeric(rngCurrentHeader) Or IsDate(rngCurrentHeader) Then rngCurrentHeader.Value = "'" & rngCurrentHeader.Value    'As per above, can't have numeric headers
   
                Next j
                arSQL(i) = "(" & Join$(arTemp, vbCr & "UNION ALL ") & ")"
            Next i
   
            ReDim arTemp(1 To rngRightHeaders.Count - (i - 1) * lngMAX_UNIONS)
            For j = LBound(arTemp) To UBound(arTemp)
                Set rngCurrentHeader = rngRightHeaders(1, (i - 1) * lngMAX_UNIONS + j)
                arTemp(j) = "SELECT " & strLeftHeaders & "[" & rngCurrentHeader.Value & "] AS Total, '" & rngCurrentHeader.Value & "' AS [" & strCrosstabName & "] FROM [" & rngCurrentHeader.Parent.Name & "$" & Replace(rngCrossTab.Address, "$", "") & "]"
                If IsNumeric(rngCurrentHeader) Or IsDate(rngCurrentHeader) Then rngCurrentHeader.Value = "'" & rngCurrentHeader.Value   'As per above, can't have numeric headers
   
            Next j
            arSQL(i) = "(" & Join$(arTemp, vbCr & "UNION ALL ") & ")"
            'Debug.Print Join$(arSQL, vbCr & "UNION ALL" & vbCr)
   
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' When using ADO with Excel data, there is a documented bug
            ' causing a memory leak unless the data is in a different
            ' workbook from the ADO workbook.
            ' http://support.microsoft.com/kb/319998
            ' So the work-around is to save a temp version somewhere else,
            ' then pull the data from the temp version, then delete the
            ' temp copy
            sTempFilePath = ActiveWorkbook.Path
            sTempFilePath = sTempFilePath & "\" & "TempFile_" & Format(Time(), "hhmmss") & ".xlsm"
            ActiveWorkbook.SaveCopyAs sTempFilePath
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   
             If Application.Version >= 12 Then
                'use ACE provider connection string
               sConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 12.0;"""
                Else
                'use JET provider connection string
                sConnection = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 8.0;"""
            End If
           
            Set objRS = CreateObject("ADODB.Recordset")
            Set oConn = CreateObject("ADODB.Connection")
           
            ' Open the ADO connection to our temp Excel workbook
            oConn.Open sConnection
           
             ' Open the recordset as a result of executing the SQL query
            objRS.Open Source:=Join$(arSQL, vbCr & "UNION ALL" & vbCr), ActiveConnection:=oConn, CursorType:=3   'adOpenStatic !!!NOTE!!! we have to use a numerical constant here, because as we are using late binding Excel doesn't have a clue what 'adOpenStatic' means
       
            Set objPivotCache = ActiveWorkbook.PivotCaches.Create(xlExternal)
            Set objPivotCache.Recordset = objRS
            Set objRS = Nothing
   
            Set pt = objPivotCache.CreatePivotTable(TableDestination:=rngOutput)
            Set objPivotCache = Nothing
   
            'Turn any numerical headings back to numbers by effectively removing any apostrophes in front
            For Each cell In rngLeftHeaders
                If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value
            Next cell
            For Each cell In rngRightHeaders
                If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value
            Next cell
   
            With pt
                .ManualUpdate = True    'stops the pt refreshing while we make chages to it.
                If Application.Version >= 14 Then TabularLayout pt
               
   
                For Each cell In rngLeftHeaders
                    With .PivotFields(cell.Value)
                        .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
                    End With
                Next cell
   
                With .PivotFields(strCrosstabName)
                    .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
                End With
   
                With .PivotFields("Total")
                    .Orientation = xlDataField
                    .Function = xlSum
                End With
                .ManualUpdate = False
            End With
            Else: MsgBox "You must first save the workbook for this code to work."
        End If
    End If
    
    
          
    unpivot = Success
       
    timetaken = timetaken - Now()
    Debug.Print "UnPivot: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")
       
   
ErrHandler:
    If Err.Number <> 0 Then
        Select Case Err.Number
            Case 999: 'User pushed cancel.
            Case Else:  MsgBox "Whoops, there was an error: Error#" & Err.Number & vbCrLf & Err.Description _
                     , vbCritical, "Error", Err.HelpFile, Err.HelpContext
        End Select
    End If

Application.ScreenUpdating = True

End Function

Private Sub TabularLayout(pt As PivotTable)
    With pt
        .RepeatAllLabels xlRepeatLabels
        .RowAxisLayout xlTabularRow
    End With
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

Option Explicit

Sub Call_UnPivot()

UnPivot

End Sub

Function unpivot(Optional rngCrossTab As Range, _

Optional rngLeftHeaders As Range, _

Optional rngRightHeaders As Range, _

Optional strCrosstabName As String, _

Optional rngOutput As Range, _

Optional bSkipBlanks As Boolean = False) As Boolean

' Desc: Turns a crosstab file into a flatfile using array manipulation.

' If the resulting flat file will be too long to fit in the worksheet,

' the routine uses SQL and lots of 'UNION ALL' statements to do the

' equivalent of the 'UNPfaddIVOT' command in SQL Server (which is not available

' in Excel)and writes the result directly to a PivotTable

' Base code for the SQL UnPivot derived from from Fazza at MR EXCEL forum:

' http://www.mrexcel.com/forum/showthread.php?315768-Creating-a-pivot-table-with-multiple-sheets

' The Microsoft JET/ACE Database engine has a hard limit of 50 'UNION ALL' clauses, but Fazza's

' code gets around this by creating sublocks of up to 25 SELECT/UNION ALL statements, and

' then unioning these.

' Programmer: Jeff Weir

' Contact: weir.jeff@gmail.com

' Name/Version: Date: Ini: Modification:

' UnPivot V1 20131122 JSW Original Development

' Inputs: Range of the entile crosstab

' Range of columns down the left that WON'T be normalized

' Range of columns down the right that WILL be normalize

' String containing the name to give columns that will be normalized

' Outputs: A pivottable of the input data on a new worksheet.

' Example:

' It takes a crosstabulated table that looks like this:

' Country Sector 1990 1991 ... 2009

' =============================================================================

' Australia Energy 290,872 296,887 ... 417,355

' New Zealand Energy 23,915 25,738 ... 31,361

' United States Energy 5,254,607 5,357,253 ... 5,751,106

' Australia Manufacturing 35,648 35,207 ... 44,514

' New Zealand Manufacturing 4,389 4,845 ... 4,907

' United States Manufacturing 852,424 837,828 ... 735,902

' Australia Transport 62,121 61,504 ... 83,645

' New Zealand Transport 8,679 8,696 ... 13,783

' United States Transport 1,484,909 1,447,234 ... 1,722,501

' And it returns the same data in a recordset organised like this:

' Country Sector Year Value

' ====================================================

' Australia Energy 1990 290,872

' New Zealand Energy 1990 23,915

' United States Energy 1990 5,254,607

' Australia Manufacturing 1990 35,648

' New Zealand Manufacturing 1990 4,389

' United States Manufacturing 1990 852,424

' Australia Transport 1990 62,121

' New Zealand Transport 1990 8,679

' United States Transport 1990 1,484,909

' Australia Energy 1991 296,887

' New Zealand Energy 1991 25,738

' United States Energy 1991 5,357,253

' Australia Manufacturing 1991 35,207

' New Zealand Manufacturing 1991 4,845

' United States Manufacturing 1991 837,828

' Australia Transport 1991 61,504

' New Zealand Transport 1991 8,696

' United States Transport 1991 1,447,234

' ... ... ... ...

' Australia Energy 2009 417,355

' New Zealand Energy 2009 31,361

' United States Energy 2009 5,751,106

' Australia Manufacturing 2009 44,514

' New Zealand Manufacturing 2009 4,907

' United States Manufacturing 2009 735,902

' Australia Transport 2009 83,645

' New Zealand Transport 2009 13,783

' United States Transport 2009 1,722,501

Const lngMAX_UNIONS As Long = 25

Dim varSource As Variant

Dim varOutput As Variant

Dim lLeftColumns As Long

Dim lRightColumns As Long

Dim i As Long

Dim j As Long

Dim m As Long

Dim n As Long

Dim lOutputRows As Long

Dim arSQL() As String

Dim arTemp() As String

Dim sTempFilePath As String

Dim objPivotCache As PivotCache

Dim objRS As Object

Dim oConn As Object

Dim sConnection As String

Dim wks As Worksheet

Dim wksNew As Worksheet

Dim cell As Range

Dim strLeftHeaders As String

Dim wksSource As Worksheet

Dim pt As PivotTable

Dim rngCurrentHeader As Range

Dim timetaken As Date

Dim strMsg As String

Dim varAnswer As Variant

Const Success As Boolean = True

Const Failure As Boolean = False

unpivot = Failure

'Identify where the ENTIRE crosstab table is

If rngCrossTab Is Nothing Then

Application.ScreenUpdating = True

On Error Resume Next

Set rngCrossTab = Application.InputBox( _

Title:="Please select the ENTIRE crosstab", _

Prompt:="Please select the ENTIRE crosstab that you want to turn into a flat file", _

Type:=8, Default:=Selection.CurrentRegion.Address)

If Err.Number <> 0 Then

On Error GoTo ErrHandler

Err.Raise 999

Else: On Error GoTo ErrHandler

End If

rngCrossTab.Parent.Activate

rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience

End If

'Identify range containing columns of interest running down the table

If rngLeftHeaders Is Nothing Then

On Error Resume Next

Set rngLeftHeaders = Application.InputBox( _

Title:="Select the column HEADERS from the LEFT of the table that WON'T be aggregated", _

Prompt:="Select the column HEADERS from the LEFT of the table that won't be aggregated", _

Default:=Selection.Address, Type:=8)

If Err.Number <> 0 Then

On Error GoTo ErrHandler

Err.Raise 999

Else: On Error GoTo ErrHandler

End If

Set rngLeftHeaders = rngLeftHeaders.Resize(1, rngLeftHeaders.Columns.Count) 'just in case they selected the entire column

Range(rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1), rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1).End(xlToRight)).Select 'Returns them to the right of the range they just selected

End If

If rngRightHeaders Is Nothing Then

'Identify range containing data and cross-tab headers running across the table

On Error Resume Next

Set rngRightHeaders = Application.InputBox( _

Title:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _

Prompt:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _

Default:=Selection.Address, _

Type:=8)

If Err.Number <> 0 Then

On Error GoTo ErrHandler

Err.Raise 999

Else: On Error GoTo ErrHandler

End If

Set rngRightHeaders = rngRightHeaders.Resize(1, rngRightHeaders.Columns.Count) 'just in case they selected the entire column

rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience

End If

If strCrosstabName = "" Then

'Get the field name for the columns being consolidated e.g. 'Country' or 'Project'. note that reserved SQL words like 'Date' cannot be used

strCrosstabName = Application.InputBox( _

Title:="What name do you want to give the data field being aggregated?", _

Prompt:="What name do you want to give the data field being aggregated? e.g. 'Date', 'Country', etc.", _

Default:="Date", _

Type:=2)

If strCrosstabName = "False" Then Err.Raise 999

End If

If rngOutput Is Nothing Then

'Identify range containing data and cross-tab headers running across the table

On Error Resume Next

Set rngOutput = Application.InputBox( _

Title:="Where do you want to output the data", _

Prompt:="Select the top left cell where you want the transformed data to be output", _

Default:=Cells(ActiveSheet.UsedRange.row, ActiveSheet.UsedRange.Columns.Count + ActiveSheet.UsedRange.Column + 1).Address, _

Type:=8)

If Err.Number <> 0 Then

On Error GoTo ErrHandler

Err.Raise 999

Else: On Error GoTo ErrHandler

End If

timetaken = Now()

Application.ScreenUpdating = False

'Work out if the worksheet has enough rows to fit a crosstab in

If Intersect(rngRightHeaders.EntireColumn, rngCrossTab).Cells.Count <= Columns(1).Rows.Count Then

'Resulting flat file will fit on the sheet, so use array manipulation.

varSource = rngCrossTab

lRightColumns = rngRightHeaders.Columns.Count

lLeftColumns = UBound(varSource, 2) - lRightColumns

If Not bSkipBlanks Then

ReDim varOutput(1 To lRightColumns * (UBound(varSource) - 1), 1 To lLeftColumns + 2)

Else

lOutputRows = Application.WorksheetFunction.CountA(Intersect([appRightHeaders].EntireColumn, rngCrossTab)) - [appRightHeaders].Cells.Count

ReDim varOutput(1 To lOutputRows, 1 To lLeftColumns + 2)

End If

If Not bSkipBlanks Then

For j = 1 To UBound(varOutput)

m = (j - 1) Mod (UBound(varSource) - 1) + 2

n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1

varOutput(j, lLeftColumns + 1) = varSource(1, n)

varOutput(j, lLeftColumns + 2) = varSource(m, n)

For i = 1 To lLeftColumns

varOutput(j, i) = varSource(m, i)

Next i

Next j

Else

lOutputRows = 1

For j = 1 To Intersect([appRightHeaders].EntireColumn, rngCrossTab).Cells.Count - [appRightHeaders].Cells.Count

m = (j - 1) Mod (UBound(varSource) - 1) + 2

n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1

If Not IsEmpty(varSource(m, n)) Then

varOutput(lOutputRows, lLeftColumns + 1) = varSource(1, n)

varOutput(lOutputRows, lLeftColumns + 2) = varSource(m, n)

For i = 1 To lLeftColumns

varOutput(lOutputRows, i) = varSource(m, i)

Next i

lOutputRows = lOutputRows + 1

End If

Next j

End If

With rngOutput

.Resize(, lLeftColumns).Value = rngLeftHeaders.Value

.Offset(, lLeftColumns).Value = strCrosstabName

.Offset(, lLeftColumns + 1).Value = "Quantity"

.Offset(1, 0).Resize(UBound(varOutput), UBound(varOutput, 2)) = varOutput

End With

Else 'Resulting flat file will fit on the sheet, so use SQL and write result directly to a pivot

strMsg = " I can't turn this crosstab into a flat file, because the crosstab is so large that"

strMsg = strMsg & " the resulting flat file will be too big to fit in a worksheet. "

strMsg = strMsg & vbNewLine & vbNewLine

strMsg = strMsg & " However, I can still turn this information directly into a PivotTable if you want."

strMsg = strMsg & " Note that this might take several minutes. Do you wish to proceed?"

varAnswer = MsgBox(Prompt:=strMsg, Buttons:=vbOK + vbCancel + vbCritical, Title:="Crosstab too large!")

If varAnswer <> 6 Then Err.Raise 999

If ActiveWorkbook.Path <> "" Then 'can only proceed if the workbook has been saved somewhere

Set wksSource = rngLeftHeaders.Parent

'Build part of SQL Statement that deals with 'static' columns i.e. the ones down the left

For Each cell In rngLeftHeaders

'For some reason this approach doesn't like columns with numeric headers.

' My solution in the below line is to prefix any numeric characters with

' an apostrophe to render them non-numeric, and restore them back to numeric

' after the query has run

If IsNumeric(cell) Or IsDate(cell) Then cell.Value = "'" & cell.Value

strLeftHeaders = strLeftHeaders & "[" & cell.Value & "], "

Next cell

ReDim arTemp(1 To lngMAX_UNIONS) 'currently 25 as per declaration at top of module

ReDim arSQL(1 To (rngRightHeaders.Count - 1) \ lngMAX_UNIONS + 1)

For i = LBound(arSQL) To UBound(arSQL) - 1

For j = LBound(arTemp) To UBound(arTemp)

Set rngCurrentHeader = rngRightHeaders(1, (i - 1) * lngMAX_UNIONS + j)

arTemp(j) = "SELECT " & strLeftHeaders & "[" & rngCurrentHeader.Value & "] AS Total, '" & rngCurrentHeader.Value & "' AS [" & strCrosstabName & "] FROM [" & rngCurrentHeader.Parent.Name & "$" & Replace(rngCrossTab.Address, "$", "") & "]"

If IsNumeric(rngCurrentHeader) Or IsDate(rngCurrentHeader) Then rngCurrentHeader.Value = "'" & rngCurrentHeader.Value 'As per above, can't have numeric headers

Next j

arSQL(i) = "(" & Join$(arTemp, vbCr & "UNION ALL ") & ")"

Next i

ReDim arTemp(1 To rngRightHeaders.Count - (i - 1) * lngMAX_UNIONS)

For j = LBound(arTemp) To UBound(arTemp)

Set rngCurrentHeader = rngRightHeaders(1, (i - 1) * lngMAX_UNIONS + j)

If IsNumeric(rngCurrentHeader) Or IsDate(rngCurrentHeader) Then rngCurrentHeader.Value = "'" & rngCurrentHeader.Value 'As per above, can't have numeric headers

Next j

arSQL(i) = "(" & Join$(arTemp, vbCr & "UNION ALL ") & ")"

'Debug.Print Join$(arSQL, vbCr & "UNION ALL" & vbCr)

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' When using ADO with Excel data, there is a documented bug

' causing a memory leak unless the data is in a different

' workbook from the ADO workbook.

' http://support.microsoft.com/kb/319998

' So the work-around is to save a temp version somewhere else,

' then pull the data from the temp version, then delete the

' temp copy

sTempFilePath = ActiveWorkbook.Path

sTempFilePath = sTempFilePath & "\" & "TempFile_" & Format(Time(), "hhmmss") & ".xlsm"

ActiveWorkbook.SaveCopyAs sTempFilePath

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If Application.Version >= 12 Then

'use ACE provider connection string

sConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 12.0;"""

Else

'use JET provider connection string

sConnection = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 8.0;"""

End If

Set objRS = CreateObject("ADODB.Recordset")

Set oConn = CreateObject("ADODB.Connection")

' Open the ADO connection to our temp Excel workbook

oConn.Open sConnection

' Open the recordset as a result of executing the SQL query

objRS.Open Source:=Join$(arSQL, vbCr & "UNION ALL" & vbCr), ActiveConnection:=oConn, CursorType:=3 'adOpenStatic !!!NOTE!!! we have to use a numerical constant here, because as we are using late binding Excel doesn't have a clue what 'adOpenStatic' means

Set objPivotCache = ActiveWorkbook.PivotCaches.Create(xlExternal)

Set objPivotCache.Recordset = objRS

Set objRS = Nothing

Set pt = objPivotCache.CreatePivotTable(TableDestination:=rngOutput)

Set objPivotCache = Nothing

'Turn any numerical headings back to numbers by effectively removing any apostrophes in front

For Each cell In rngLeftHeaders

If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value

Next cell

For Each cell In rngRightHeaders

If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value

Next cell

With pt

.ManualUpdate = True 'stops the pt refreshing while we make chages to it.

If Application.Version >= 14 Then TabularLayout pt

For Each cell In rngLeftHeaders

With .PivotFields(cell.Value)

.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)

End With

Next cell

With .PivotFields(strCrosstabName)

.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)

End With

With .PivotFields("Total")

.Orientation = xlDataField

.Function = xlSum

End With

.ManualUpdate = False

End With

Else: MsgBox "You must first save the workbook for this code to work."

End If

unpivot = Success

timetaken = timetaken - Now()

Debug.Print "UnPivot: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")

ErrHandler:

If Err.Number <> 0 Then

Select Case Err.Number

Case 999: 'User pushed cancel.

Case Else: MsgBox "Whoops, there was an error: Error#" & Err.Number & vbCrLf & Err.Description _

, vbCritical, "Error", Err.HelpFile, Err.HelpContext

End Select

End If

Application.ScreenUpdating = True

End Function

Private Sub TabularLayout(pt As PivotTable)

With pt

.RepeatAllLabels xlRepeatLabels

.RowAxisLayout xlTabularRow

End With

End Sub

In an ideal world

Posted on November 21, 2013November 21, 2013 by Jeff Weir

Howdy folks. Jeff here, with yet another post on Pivot Tables.

Just kidding. :-)

My good internet pal Craig Hatmaker gives me a friendly ribbing every time I send him some code that does something in Excel that a database could implement much more efficiently. He points out that because he’s in IT, he doesn’t have anyone stopping him from doing things as he thinks they should be done. So he has no impediment to doing what seems ideal to him.

And he points out that you needn’t be from an IT background in order to replicate his type of approach: if you can master xl, you can master databases. (And he should know: check out his amazing Beyond Excel: VBA and Database Manipulation blog, where he starts off with looking at how to use simple things like Microsoft Query to get data, then progressively teaches you more and more every post until you’re using excel to add records to an access database using a table driven approach, so you don’t have to write SQL or update a single line of code. )

I agree 100%. If you can master xl, you can master databases. The problem is, most people don’t master the first. And out of those that do, many don’t choose to master the second. So the majority will continue to shoehorn large datasets into Excel crosstabs, and then do incredibly convoluted things in order to get the equivalent functionality of a PivotTable out of those crosstabs.

And so I’ll continue to build routines like my Unpivot Via SQL and Filter Pivots Based on External ranges to help them manage their lunacy. Even though I know I shouldn’t encourage them.

This reminds me of the conversation in the comments over at Chandoo’s blog in his post on Speedo Charts called Hack together a Gauge Chart in Excel without sweat, but which Jon Peltier would likely retitle Speedo Charts: The Little Chart That Shouldn’t:

Jon Peltier: Speedo charts? Do you really want to encourage such poor presentation techniques
Me: Despite the fact that we “shouldn’t really” use dials, I think that if a paying client or monster boss wants them and it’s a deal-breaker, then we best know how to whip one up.
Chandoo: As long as we have bosses asking for gauges, we will have gauge charts.
Anonymous Reader: Thank you for you posts Chandoo. Gauge/Speedometer chart is exactly what my superiors asked me to make for next EB meeting.
Jon: Another happy reader led astray by the gauge chart instructions in this post.
Me: Here’s a legitimate speedo chart that I’m sure even Stephen Few couldn’t argue with:

Explanation for non-Australian or non-New Zealand readers:
Speedos: Gentlemen’s bathing suit, typically in close form-fitting style.
Bonza: Slang for “remarkable or wonderful”
Crikey Dick: expression of surprise

Craig sums this up this tension between utopia and reality really succinctly: “That’s why we work in opposite directions. I do what seems ideal. You do what is necessary given restraints.”

*Sigh*. Afraid so. On the upside, I’ve formulated this into two helpful business rules:

Rule number 1: As long as clients keep shoehorning large amount of data badly in Excel, they will inevitably get into an urgent pickle.
Rule number 2: As long as Rule Number 1 holds true, I will continue to charge an ‘urgent pickle’ hourly rate.

On rule number 1, I’ve told several clients again and again that they need to migrate their 100MB+ spreadsheets to 0.05 MB database tables. I point out that these spreadsheets are inevitably just one in a chain of fat spreadsheets that contain data they use to make up monthly reports for clients. And I highlight that just getting those monthly BAU reports out the door inevitably has become a full-time exercise.
But they won’t migrate this data to a more sensible solution, because:

They don’t know whether the benefit of migration will outweigh the cost, and/or
They don’t want the hassle of working out how to migrate, and/or
They don’t want to master SQL, and/or
I’m really crap at communicating this stuff, and/or
This is the least pressing of their pressing business issues.

On that second point, I point out that their existing process is nothing but hassle, and that it will be a real big hassle when their spreadsheet finally dies, along with all their data. And on point 5, by the time this becomes the most pressing of their pressing business issues, they no longer have a business.

On that 3rd point, they generally answer “we are Economists/Accountants/Whatevers, not Data Analysts”. I say “Given your business is built around data, you are Data Analysts first, and Whatevers second”.
Cue blank stare.
*Sigh*

UnPivot via SQL

Posted on November 19, 2013March 17, 2018 by Jeff Weir

Howdy folks. Jeff Pivot…err…Weir here again.

Recently Ken Puls did a handy post on how to unpivot data using PowerQuery. Jan Karel commented that you can do this using Multiple Consolidation Ranges. That’s true, but what I like about the PowerQuery approach is that you can translate the currently selected columns into attribute-value pairs, combined with the rest of the values in each row. That is, you can have multiple hierarchical columns down the left of your CrossTab as well as the column headers across the top that you want to amalgamate. Which is great if you have a crosstab like this:

Whereas the Multiple Consolidation trick only handles one column down the left out of the box.

Mike Alexander posted a great bacon-tasting morsel of a trick to get around that issue way back in 2009 when he used to blog. He simply concatenating all the non-column-oriented fields into one dimension field into one temporary column. Check out his post Transposing a Dataset with a PivotTable. But as commenter dermotb said…it’s like a magic spell that you have to write down somewhere, and try to find when you need it, because it’s complex. (I love Mike’s reply to that: Come on. Excel is full of magic syntax, mystical hot keys, and vba voodoo that requires some level of memorizing steps. That’s why I can make a living peddling “tips and tricks”.)

Another problem with the Multiple Consolidation trick is that you might well end up with more data than fits in your sheet, by the time you flatten it out. Especially in old Excel. Because the number of rows you end up with in a flat file is the number of rows you start off with times the number of columns that you’re going to amalgamate. So for say a time-series dataset that covers quite a few items and a reasonable period of time, you could be in trouble.

So a while ago I had a crack at writing a SQL routine that unpivots by doing lots of UNION ALL joins, and writes the data directly to a PivotTable. The UNION ALLs are required because the pidgin English version of SQL that Excel speaks (and Access too, I guess) doesn’t have a UNPIVOT command.

I struck a few hurdles along the way. For instance, it turns out that the Microsoft JET/ACE Database engine has a hard limit of 50 ‘UNION ALL’ clauses, which you will soon exceed if you have a big crosstab with multiple columns down the left. I found a great thread over at MrExcel at which Fazza overcame this hard limit by creating sub-blocks of UNION ALL statements, then stiching them all together with another UNION ALL. Another problem is that SQL didn’t like dates (and sometimes numbers) in the headers. So I turn them into text with an apostrophe.

And another thing I do is save a temp version of the file somewhere, and then query that temp version rather than querying the open workbook. Even though the Memory Leak issue that this avoids has been largely fixed in New Excel, I still found that querying the open book was causing grief occasionally.

Anyway, here’s the result. I’ve turned it into a function, and you can pre-specify inputs if you like. Otherwise you’ll be prompted for the following:

…and then you’ll get a Pivot:

Take it for a spin, let me know of any issues in the comments. Note that I’ve tried to code it to handle Excel 2003 and earlier, but I don’t have old Excel anymore so couldn’t test it. In fact, that’s why the TabularLayout sub is separate – I had to put it in a subroutine because if someone has ‘old’ Excel then the main function wouldn’t compile.

—Edit 11 March 2014—
I’ve updated the below code to incorporate snb’s approach using array manipulation from Unpivot Shootout where possible.

Cheers

Jeff

Function unpivot(Optional rngCrossTab As Range, _
                      Optional rngLeftHeaders As Range, _
                      Optional rngRightHeaders As Range, _
                      Optional strCrosstabName As String, _
                      Optional rngOutput As Range, _
                      Optional bSkipBlanks As Boolean = False) As Boolean

'   Desc:   Turns a crosstab file into a flatfile using array manipulation.
'           If the resulting flat file will be too long to fit in the worksheet,
'           the routine uses SQL and lots of 'UNION ALL' statements to do the
'           equivalent of the 'UNPfaddIVOT' command in SQL Server (which is not available
'           in Excel)and writes the result directly to a PivotTable

'           Base code for the SQL UnPivot devived from from Fazza at MR EXCEL forum:
'           http://www.mrexcel.com/forum/showthread.php?315768-Creating-a-pivot-table-with-multiple-sheets
'           The Microsoft JET/ACE Database engine has a hard limit of 50 'UNION ALL' clauses, but Fazza's
'           code gets around this by creating sublocks of up to 25 SELECT/UNION ALL statements, and
'           then unioning these.


'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com

'   Name/Version:    Date:      Ini:    Modification:
'   UnPivot V1      20131122    JSW     Original Development
   
'   Inputs:         Range of the entile crosstab
'                   Range of columns down the left that WON'T be normalized
'                   Range of columns down the right that WILL be normalize
'                   String containing the name to give columns that will be normalized

'   Outputs:        A pivottable of the input data on a new worksheet.

'   Example:

'   It takes a crosstabulated table that looks like this:

'   Country        Sector          1990        1991        ...         2009
'   =============================================================================
'   Australia      Energy          290,872     296,887     ...         417,355
'   New Zealand    Energy          23,915      25,738      ...         31,361
'   United States  Energy          5,254,607   5,357,253   ...         5,751,106
'   Australia      Manufacturing   35,648      35,207      ...         44,514
'   New Zealand    Manufacturing   4,389       4,845       ...         4,907
'   United States  Manufacturing   852,424     837,828     ...         735,902
'   Australia      Transport       62,121      61,504      ...         83,645
'   New Zealand    Transport       8,679       8,696       ...         13,783
'   United States  Transport       1,484,909   1,447,234   ...         1,722,501



'   And it returns the same data in a recordset organised like this:

'   Country        Sector          Year        Value
'   ====================================================
'   Australia      Energy          1990        290,872
'   New Zealand    Energy          1990        23,915
'   United States  Energy          1990        5,254,607
'   Australia      Manufacturing   1990        35,648
'   New Zealand    Manufacturing   1990        4,389
'   United States  Manufacturing   1990        852,424
'   Australia      Transport       1990        62,121
'   New Zealand    Transport       1990        8,679
'   United States  Transport       1990        1,484,909
'   Australia      Energy          1991        296,887
'   New Zealand    Energy          1991        25,738
'   United States  Energy          1991        5,357,253
'   Australia      Manufacturing   1991        35,207
'   New Zealand    Manufacturing   1991        4,845
'   United States  Manufacturing   1991        837,828
'   Australia      Transport       1991        61,504
'   New Zealand    Transport       1991        8,696
'   United States  Transport       1991        1,447,234
'   ...            ...             ...         ...
'   ...            ...             ...         ...
'   ...            ...             ...         ...
'   Australia      Energy          2009        417,355
'   New Zealand    Energy          2009        31,361
'   United States  Energy          2009        5,751,106
'   Australia      Manufacturing   2009        44,514
'   New Zealand    Manufacturing   2009        4,907
'   United States  Manufacturing   2009        735,902
'   Australia      Transport       2009        83,645
'   New Zealand    Transport       2009        13,783
'   United States  Transport       2009        1,722,501


    Const lngMAX_UNIONS As Long = 25

    Dim varSource As Variant
    Dim varOutput As Variant
    Dim lLeftColumns As Long
    Dim lRightColumns As Long
    Dim i As Long
    Dim j As Long
    Dim m As Long
    Dim n As Long
    Dim lOutputRows As Long
    Dim arSQL() As String
    Dim arTemp() As String
    Dim sTempFilePath As String
    Dim objPivotCache As PivotCache
    Dim objRS As Object
    Dim oConn As Object
    Dim sConnection As String
    Dim wks As Worksheet
    Dim wksNew As Worksheet
    Dim cell As Range
    Dim strLeftHeaders As String
    Dim wksSource As Worksheet
    Dim pt As PivotTable
    Dim rngCurrentHeader As Range
    Dim timetaken As Date
    Dim strMsg As String
    Dim varAnswer As Variant

    Const Success As Boolean = True
    Const Failure As Boolean = False

    unpivot = Failure

    
    'Identify where the ENTIRE crosstab table is
    If rngCrossTab Is Nothing Then
        Application.ScreenUpdating = True
        On Error Resume Next
        Set rngCrossTab = Application.InputBox( _
                          Title:="Please select the ENTIRE crosstab", _
                          prompt:="Please select the ENTIRE crosstab that you want to turn into a flat file", _
                          Type:=8, Default:=Selection.CurrentRegion.Address)
        If Err.Number <> 0 Then
            On Error GoTo errhandler
            Err.Raise 999
        Else: On Error GoTo errhandler
        End If
        rngCrossTab.Parent.Activate
        rngCrossTab.Cells(1, 1).Select    'Returns them to the top left of the source table for convenience
    End If

    'Identify range containing columns of interest running down the table
    If rngLeftHeaders Is Nothing Then
        On Error Resume Next
        Set rngLeftHeaders = Application.InputBox( _
                             Title:="Select the column HEADERS from the LEFT of the table that WON'T be aggregated", _
                             prompt:="Select the column HEADERS from the LEFT of the table that won't be aggregated", _
                             Default:=Selection.Address, Type:=8)
        If Err.Number <> 0 Then
            On Error GoTo errhandler
            Err.Raise 999
        Else: On Error GoTo errhandler
        End If
        Set rngLeftHeaders = rngLeftHeaders.Resize(1, rngLeftHeaders.Columns.Count)    'just in case they selected the entire column
        rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1).Select    'Returns them to the right of the range they just selected
    End If


    If rngRightHeaders Is Nothing Then
        'Identify range containing data and cross-tab headers running across the table
        On Error Resume Next
        Set rngRightHeaders = Application.InputBox( _
                              Title:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
                              prompt:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
                              Default:=Selection.Address, _
                              Type:=8)
         If Err.Number <> 0 Then
            On Error GoTo errhandler
            Err.Raise 999
        Else: On Error GoTo errhandler
        End If
        Set rngRightHeaders = rngRightHeaders.Resize(1, rngRightHeaders.Columns.Count)    'just in case they selected the entire column
        rngCrossTab.Cells(1, 1).Select    'Returns them to the top left of the source table for convenience
    End If


    If strCrosstabName = "" Then
        'Get the field name for the columns being consolidated e.g. 'Country' or 'Project'. note that reserved SQL words like 'Date' cannot be used
        strCrosstabName = Application.InputBox( _
                          Title:="What name do you want to give the data field being aggregated?", _
                          prompt:="What name do you want to give the data field being aggregated? e.g. 'Date', 'Country', etc.", _
                          Default:="Date", _
                          Type:=2)
         If strCrosstabName = "False" Then Err.Raise 999
    End If

    If rngOutput Is Nothing Then
        'Identify range containing data and cross-tab headers running across the table
        On Error Resume Next
        Set rngOutput = Application.InputBox( _
                              Title:="Where do you want to output the data", _
                              prompt:="Select the top left cell where you want the transformed data to be output", _
                              Default:=Selection.Address, _
                              Type:=8)
         If Err.Number <> 0 Then
            On Error GoTo errhandler
            Err.Raise 999
        Else: On Error GoTo errhandler
        End If
    End If



    timetaken = Now()
    Application.ScreenUpdating = False
       
    'Work out if the worksheet has enough rows to fit a crosstab in
    If Intersect(rngRightHeaders.EntireColumn, rngCrossTab).Cells.Count <= Columns(1).Rows.Count Then
        'Resulting flat file will fit on the sheet, so use array manipulation.
        varSource = rngCrossTab
        lRightColumns = rngRightHeaders.Columns.Count
        lLeftColumns = UBound(varSource, 2) - lRightColumns
        
        If Not bSkipBlanks Then
            ReDim varOutput(1 To lRightColumns * (UBound(varSource) - 1), 1 To lLeftColumns + 2)
        Else
            lOutputRows = Application.WorksheetFunction.CountA(Intersect([appRightHeaders].EntireColumn, rngCrossTab)) - [appRightHeaders].Cells.Count
            ReDim varOutput(1 To lOutputRows, 1 To lLeftColumns + 2)
        End If

        If Not bSkipBlanks Then
            For j = 1 To UBound(varOutput)
                m = (j - 1) Mod (UBound(varSource) - 1) + 2
                n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1
                varOutput(j, lLeftColumns + 1) = varSource(1, n)
                varOutput(j, lLeftColumns + 2) = varSource(m, n)
                For i = 1 To lLeftColumns
                    varOutput(j, i) = varSource(m, i)
                Next i
            Next j
        Else
            lOutputRows = 1
            For j = 1 To Intersect([appRightHeaders].EntireColumn, rngCrossTab).Cells.Count - [appRightHeaders].Cells.Count
                m = (j - 1) Mod (UBound(varSource) - 1) + 2
                n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1
                If Not IsEmpty(varSource(m, n)) Then
                    varOutput(lOutputRows, lLeftColumns + 1) = varSource(1, n)
                    varOutput(lOutputRows, lLeftColumns + 2) = varSource(m, n)
                    For i = 1 To lLeftColumns
                        varOutput(lOutputRows, i) = varSource(m, i)
                    Next i
                    lOutputRows = lOutputRows + 1
                End If
            Next j
            
            End If
       

   
        With rngOutput
            .Resize(, lLeftColumns).Value = rngLeftHeaders.Value
            .Offset(, lLeftColumns).Value = strCrosstabName
            .Offset(, lLeftColumns + 1).Value = "Quantity"
            .Offset(1, 0).Resize(UBound(varOutput), UBound(varOutput, 2)) = varOutput
        End With
           
    Else 'Resulting flat file will fit on the sheet, so use SQL and write result directly to a pivot
        strMsg = " I can't turn this crosstab into a flat file, because the crosstab is so large that"
        strMsg = strMsg & " the resulting flat file will be too big to fit in a worksheet. "
        strMsg = strMsg & vbNewLine & vbNewLine
        strMsg = strMsg & " However, I can still turn this information directly into a PivotTable if you want."
        strMsg = strMsg & " Note that this might take several minutes. Do you wish to proceed?"
        varAnswer = MsgBox(prompt:=strMsg, Buttons:=vbOK + vbCancel + vbCritical, Title:="Crosstab too large!")
        If varAnswer <> 6 Then Err.Raise 999

        If ActiveWorkbook.Path <> "" Then    'can only proceed if the workbook has been saved somewhere
            Set wksSource = rngLeftHeaders.Parent
   
            'Build part of SQL Statement that deals with 'static' columns i.e. the ones down the left
            For Each cell In rngLeftHeaders
           
                'For some reason this approach doesn't like columns with numeric headers.
                ' My solution in the below line is to prefix any numeric characters with
                ' an apostrophe to render them non-numeric, and restore them back to numeric
                ' after the query has run
               
                If IsNumeric(cell) Or IsDate(cell) Then cell.Value = "'" & cell.Value
                strLeftHeaders = strLeftHeaders & "[" & cell.Value & "], "
               
            Next cell
   
            ReDim arTemp(1 To lngMAX_UNIONS)    'currently 25 as per declaration at top of module
   
            ReDim arSQL(1 To (rngRightHeaders.Count - 1) \ lngMAX_UNIONS + 1)
   
            For i = LBound(arSQL) To UBound(arSQL) - 1
                For j = LBound(arTemp) To UBound(arTemp)
                    Set rngCurrentHeader = rngRightHeaders(1, (i - 1) * lngMAX_UNIONS + j)
   
                    arTemp(j) = "SELECT " & strLeftHeaders & "[" & rngCurrentHeader.Value & "] AS Total, '" & rngCurrentHeader.Value & "' AS [" & strCrosstabName & "] FROM [" & rngCurrentHeader.Parent.Name & "$" & Replace(rngCrossTab.Address, "$", "") & "]"
                    If IsNumeric(rngCurrentHeader) Or IsDate(rngCurrentHeader) Then rngCurrentHeader.Value = "'" & rngCurrentHeader.Value    'As per above, can't have numeric headers
   
                Next j
                arSQL(i) = "(" & Join$(arTemp, vbCr & "UNION ALL ") & ")"
            Next i
   
            ReDim arTemp(1 To rngRightHeaders.Count - (i - 1) * lngMAX_UNIONS)
            For j = LBound(arTemp) To UBound(arTemp)
                Set rngCurrentHeader = rngRightHeaders(1, (i - 1) * lngMAX_UNIONS + j)
                arTemp(j) = "SELECT " & strLeftHeaders & "[" & rngCurrentHeader.Value & "] AS Total, '" & rngCurrentHeader.Value & "' AS [" & strCrosstabName & "] FROM [" & rngCurrentHeader.Parent.Name & "$" & Replace(rngCrossTab.Address, "$", "") & "]"
                If IsNumeric(rngCurrentHeader) Or IsDate(rngCurrentHeader) Then rngCurrentHeader.Value = "'" & rngCurrentHeader.Value   'As per above, can't have numeric headers
   
            Next j
            arSQL(i) = "(" & Join$(arTemp, vbCr & "UNION ALL ") & ")"
            'Debug.Print Join$(arSQL, vbCr & "UNION ALL" & vbCr)
   
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' When using ADO with Excel data, there is a documented bug
            ' causing a memory leak unless the data is in a different
            ' workbook from the ADO workbook.
            ' http://support.microsoft.com/kb/319998
            ' So the work-around is to save a temp version somewhere else,
            ' then pull the data from the temp version, then delete the
            ' temp copy
            sTempFilePath = ActiveWorkbook.Path
            sTempFilePath = sTempFilePath & "\" & "TempFile_" & Format(Time(), "hhmmss") & ".xlsm"
            ActiveWorkbook.SaveCopyAs sTempFilePath
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   
             If Application.Version >= 12 Then
                'use ACE provider connection string
               sConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 12.0;"""
                Else
                'use JET provider connection string
                sConnection = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 8.0;"""
            End If
           
            Set objRS = CreateObject("ADODB.Recordset")
            Set oConn = CreateObject("ADODB.Connection")
           
            ' Open the ADO connection to our temp Excel workbook
            oConn.Open sConnection
           
             ' Open the recordset as a result of executing the SQL query
            objRS.Open Source:=Join$(arSQL, vbCr & "UNION ALL" & vbCr), ActiveConnection:=oConn, CursorType:=3   'adOpenStatic !!!NOTE!!! we have to use a numerical constant here, because as we are using late binding Excel doesn't have a clue what 'adOpenStatic' means
       
            Set objPivotCache = ActiveWorkbook.PivotCaches.Create(xlExternal)
            Set objPivotCache.Recordset = objRS
            Set objRS = Nothing
   
            Set pt = objPivotCache.CreatePivotTable(TableDestination:=rngOutput)
            Set objPivotCache = Nothing
   
            'Turn any numerical headings back to numbers by effectively removing any apostrophes in front
            For Each cell In rngLeftHeaders
                If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value
            Next cell
            For Each cell In rngRightHeaders
                If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value
            Next cell
   
            With pt
                .ManualUpdate = True    'stops the pt refreshing while we make chages to it.
                If Application.Version >= 14 Then TabularLayout pt
               
   
                For Each cell In rngLeftHeaders
                    With .PivotFields(cell.Value)
                        .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
                    End With
                Next cell
   
                With .PivotFields(strCrosstabName)
                    .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
                End With
   
                With .PivotFields("Total")
                    .Orientation = xlDataField
                    .Function = xlSum
                End With
                .ManualUpdate = False
            End With
            Else: MsgBox "You must first save the workbook for this code to work."
        End If
    End If
    
    
          
    unpivot = Success
       
    timetaken = timetaken - Now()
    Debug.Print "UnPivot: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")
       
   
errhandler:
    If Err.Number <> 0 Then
        Select Case Err.Number
            Case 999: 'User pushed cancel.
            Case Else:  MsgBox "Whoops, there was an error: Error#" & Err.Number & vbCrLf & Err.Description _
                     , vbCritical, "Error", Err.HelpFile, Err.HelpContext
        End Select
    End If

Application.ScreenUpdating = True

End Function

Private Sub TabularLayout(pt As PivotTable)

    With pt
        .RepeatAllLabels xlRepeatLabels
        .RowAxisLayout xlTabularRow
    End With
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

Function unpivot(Optional rngCrossTab As Range, _

Optional rngLeftHeaders As Range, _

Optional rngRightHeaders As Range, _

Optional strCrosstabName As String, _

Optional rngOutput As Range, _

Optional bSkipBlanks As Boolean = False) As Boolean

' Desc: Turns a crosstab file into a flatfile using array manipulation.

' If the resulting flat file will be too long to fit in the worksheet,

' the routine uses SQL and lots of 'UNION ALL' statements to do the

' equivalent of the 'UNPfaddIVOT' command in SQL Server (which is not available

' in Excel)and writes the result directly to a PivotTable

' Base code for the SQL UnPivot devived from from Fazza at MR EXCEL forum:

' http://www.mrexcel.com/forum/showthread.php?315768-Creating-a-pivot-table-with-multiple-sheets

' The Microsoft JET/ACE Database engine has a hard limit of 50 'UNION ALL' clauses, but Fazza's

' code gets around this by creating sublocks of up to 25 SELECT/UNION ALL statements, and

' then unioning these.

' Programmer: Jeff Weir

' Contact: weir.jeff@gmail.com

' Name/Version: Date: Ini: Modification:

' UnPivot V1 20131122 JSW Original Development

' Inputs: Range of the entile crosstab

' Range of columns down the left that WON'T be normalized

' Range of columns down the right that WILL be normalize

' String containing the name to give columns that will be normalized

' Outputs: A pivottable of the input data on a new worksheet.

' Example:

' It takes a crosstabulated table that looks like this:

' Country Sector 1990 1991 ... 2009

' =============================================================================

' Australia Energy 290,872 296,887 ... 417,355

' New Zealand Energy 23,915 25,738 ... 31,361

' United States Energy 5,254,607 5,357,253 ... 5,751,106

' Australia Manufacturing 35,648 35,207 ... 44,514

' New Zealand Manufacturing 4,389 4,845 ... 4,907

' United States Manufacturing 852,424 837,828 ... 735,902

' Australia Transport 62,121 61,504 ... 83,645

' New Zealand Transport 8,679 8,696 ... 13,783

' United States Transport 1,484,909 1,447,234 ... 1,722,501

' And it returns the same data in a recordset organised like this:

' Country Sector Year Value

' ====================================================

' Australia Energy 1990 290,872

' New Zealand Energy 1990 23,915

' United States Energy 1990 5,254,607

' Australia Manufacturing 1990 35,648

' New Zealand Manufacturing 1990 4,389

' United States Manufacturing 1990 852,424

' Australia Transport 1990 62,121

' New Zealand Transport 1990 8,679

' United States Transport 1990 1,484,909

' Australia Energy 1991 296,887

' New Zealand Energy 1991 25,738

' United States Energy 1991 5,357,253

' Australia Manufacturing 1991 35,207

' New Zealand Manufacturing 1991 4,845

' United States Manufacturing 1991 837,828

' Australia Transport 1991 61,504

' New Zealand Transport 1991 8,696

' United States Transport 1991 1,447,234

' ... ... ... ...

' Australia Energy 2009 417,355

' New Zealand Energy 2009 31,361

' United States Energy 2009 5,751,106

' Australia Manufacturing 2009 44,514

' New Zealand Manufacturing 2009 4,907

' United States Manufacturing 2009 735,902

' Australia Transport 2009 83,645

' New Zealand Transport 2009 13,783

' United States Transport 2009 1,722,501

Const lngMAX_UNIONS As Long = 25

Dim varSource As Variant

Dim varOutput As Variant

Dim lLeftColumns As Long

Dim lRightColumns As Long

Dim i As Long

Dim j As Long

Dim m As Long

Dim n As Long

Dim lOutputRows As Long

Dim arSQL() As String

Dim arTemp() As String

Dim sTempFilePath As String

Dim objPivotCache As PivotCache

Dim objRS As Object

Dim oConn As Object

Dim sConnection As String

Dim wks As Worksheet

Dim wksNew As Worksheet

Dim cell As Range

Dim strLeftHeaders As String

Dim wksSource As Worksheet

Dim pt As PivotTable

Dim rngCurrentHeader As Range

Dim timetaken As Date

Dim strMsg As String

Dim varAnswer As Variant

Const Success As Boolean = True

Const Failure As Boolean = False

unpivot = Failure

'Identify where the ENTIRE crosstab table is

If rngCrossTab Is Nothing Then

Application.ScreenUpdating = True

On Error Resume Next

Set rngCrossTab = Application.InputBox( _

Title:="Please select the ENTIRE crosstab", _

prompt:="Please select the ENTIRE crosstab that you want to turn into a flat file", _

Type:=8, Default:=Selection.CurrentRegion.Address)

If Err.Number <> 0 Then

On Error GoTo errhandler

Err.Raise 999

Else: On Error GoTo errhandler

End If

rngCrossTab.Parent.Activate

rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience

End If

'Identify range containing columns of interest running down the table

If rngLeftHeaders Is Nothing Then

On Error Resume Next

Set rngLeftHeaders = Application.InputBox( _

Title:="Select the column HEADERS from the LEFT of the table that WON'T be aggregated", _

prompt:="Select the column HEADERS from the LEFT of the table that won't be aggregated", _

Default:=Selection.Address, Type:=8)

If Err.Number <> 0 Then

On Error GoTo errhandler

Err.Raise 999

Else: On Error GoTo errhandler

End If

Set rngLeftHeaders = rngLeftHeaders.Resize(1, rngLeftHeaders.Columns.Count) 'just in case they selected the entire column

rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1).Select 'Returns them to the right of the range they just selected

End If

If rngRightHeaders Is Nothing Then

'Identify range containing data and cross-tab headers running across the table

On Error Resume Next

Set rngRightHeaders = Application.InputBox( _

Title:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _

prompt:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _

Default:=Selection.Address, _

Type:=8)

If Err.Number <> 0 Then

On Error GoTo errhandler

Err.Raise 999

Else: On Error GoTo errhandler

End If

Set rngRightHeaders = rngRightHeaders.Resize(1, rngRightHeaders.Columns.Count) 'just in case they selected the entire column

rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience

End If

If strCrosstabName = "" Then

'Get the field name for the columns being consolidated e.g. 'Country' or 'Project'. note that reserved SQL words like 'Date' cannot be used

strCrosstabName = Application.InputBox( _

Title:="What name do you want to give the data field being aggregated?", _

prompt:="What name do you want to give the data field being aggregated? e.g. 'Date', 'Country', etc.", _

Default:="Date", _

Type:=2)

If strCrosstabName = "False" Then Err.Raise 999

End If

If rngOutput Is Nothing Then

'Identify range containing data and cross-tab headers running across the table

On Error Resume Next

Set rngOutput = Application.InputBox( _

Title:="Where do you want to output the data", _

prompt:="Select the top left cell where you want the transformed data to be output", _

Default:=Selection.Address, _

Type:=8)

If Err.Number <> 0 Then

On Error GoTo errhandler

Err.Raise 999

Else: On Error GoTo errhandler

End If

timetaken = Now()

Application.ScreenUpdating = False

'Work out if the worksheet has enough rows to fit a crosstab in

If Intersect(rngRightHeaders.EntireColumn, rngCrossTab).Cells.Count <= Columns(1).Rows.Count Then

'Resulting flat file will fit on the sheet, so use array manipulation.

varSource = rngCrossTab

lRightColumns = rngRightHeaders.Columns.Count

lLeftColumns = UBound(varSource, 2) - lRightColumns

If Not bSkipBlanks Then

ReDim varOutput(1 To lRightColumns * (UBound(varSource) - 1), 1 To lLeftColumns + 2)

Else

lOutputRows = Application.WorksheetFunction.CountA(Intersect([appRightHeaders].EntireColumn, rngCrossTab)) - [appRightHeaders].Cells.Count

ReDim varOutput(1 To lOutputRows, 1 To lLeftColumns + 2)

End If

If Not bSkipBlanks Then

For j = 1 To UBound(varOutput)

m = (j - 1) Mod (UBound(varSource) - 1) + 2

n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1

varOutput(j, lLeftColumns + 1) = varSource(1, n)

varOutput(j, lLeftColumns + 2) = varSource(m, n)

For i = 1 To lLeftColumns

varOutput(j, i) = varSource(m, i)

Next i

Next j

Else

lOutputRows = 1

For j = 1 To Intersect([appRightHeaders].EntireColumn, rngCrossTab).Cells.Count - [appRightHeaders].Cells.Count

m = (j - 1) Mod (UBound(varSource) - 1) + 2

n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1

If Not IsEmpty(varSource(m, n)) Then

varOutput(lOutputRows, lLeftColumns + 1) = varSource(1, n)

varOutput(lOutputRows, lLeftColumns + 2) = varSource(m, n)

For i = 1 To lLeftColumns

varOutput(lOutputRows, i) = varSource(m, i)

Next i

lOutputRows = lOutputRows + 1

End If

Next j

End If

With rngOutput

.Resize(, lLeftColumns).Value = rngLeftHeaders.Value

.Offset(, lLeftColumns).Value = strCrosstabName

.Offset(, lLeftColumns + 1).Value = "Quantity"

.Offset(1, 0).Resize(UBound(varOutput), UBound(varOutput, 2)) = varOutput

End With

Else 'Resulting flat file will fit on the sheet, so use SQL and write result directly to a pivot

strMsg = " I can't turn this crosstab into a flat file, because the crosstab is so large that"

strMsg = strMsg & " the resulting flat file will be too big to fit in a worksheet. "

strMsg = strMsg & vbNewLine & vbNewLine

strMsg = strMsg & " However, I can still turn this information directly into a PivotTable if you want."

strMsg = strMsg & " Note that this might take several minutes. Do you wish to proceed?"

varAnswer = MsgBox(prompt:=strMsg, Buttons:=vbOK + vbCancel + vbCritical, Title:="Crosstab too large!")

If varAnswer <> 6 Then Err.Raise 999

If ActiveWorkbook.Path <> "" Then 'can only proceed if the workbook has been saved somewhere

Set wksSource = rngLeftHeaders.Parent

'Build part of SQL Statement that deals with 'static' columns i.e. the ones down the left

For Each cell In rngLeftHeaders

'For some reason this approach doesn't like columns with numeric headers.

' My solution in the below line is to prefix any numeric characters with

' an apostrophe to render them non-numeric, and restore them back to numeric

' after the query has run

If IsNumeric(cell) Or IsDate(cell) Then cell.Value = "'" & cell.Value

strLeftHeaders = strLeftHeaders & "[" & cell.Value & "], "

Next cell

ReDim arTemp(1 To lngMAX_UNIONS) 'currently 25 as per declaration at top of module

ReDim arSQL(1 To (rngRightHeaders.Count - 1) \ lngMAX_UNIONS + 1)

For i = LBound(arSQL) To UBound(arSQL) - 1

For j = LBound(arTemp) To UBound(arTemp)

Set rngCurrentHeader = rngRightHeaders(1, (i - 1) * lngMAX_UNIONS + j)

If IsNumeric(rngCurrentHeader) Or IsDate(rngCurrentHeader) Then rngCurrentHeader.Value = "'" & rngCurrentHeader.Value 'As per above, can't have numeric headers

Next j

arSQL(i) = "(" & Join$(arTemp, vbCr & "UNION ALL ") & ")"

Next i

ReDim arTemp(1 To rngRightHeaders.Count - (i - 1) * lngMAX_UNIONS)

For j = LBound(arTemp) To UBound(arTemp)

Set rngCurrentHeader = rngRightHeaders(1, (i - 1) * lngMAX_UNIONS + j)

If IsNumeric(rngCurrentHeader) Or IsDate(rngCurrentHeader) Then rngCurrentHeader.Value = "'" & rngCurrentHeader.Value 'As per above, can't have numeric headers

Next j

arSQL(i) = "(" & Join$(arTemp, vbCr & "UNION ALL ") & ")"

'Debug.Print Join$(arSQL, vbCr & "UNION ALL" & vbCr)

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' When using ADO with Excel data, there is a documented bug

' causing a memory leak unless the data is in a different

' workbook from the ADO workbook.

' http://support.microsoft.com/kb/319998

' So the work-around is to save a temp version somewhere else,

' then pull the data from the temp version, then delete the

' temp copy

sTempFilePath = ActiveWorkbook.Path

sTempFilePath = sTempFilePath & "\" & "TempFile_" & Format(Time(), "hhmmss") & ".xlsm"

ActiveWorkbook.SaveCopyAs sTempFilePath

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If Application.Version >= 12 Then

'use ACE provider connection string

sConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 12.0;"""

Else

'use JET provider connection string

sConnection = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 8.0;"""

End If

Set objRS = CreateObject("ADODB.Recordset")

Set oConn = CreateObject("ADODB.Connection")

' Open the ADO connection to our temp Excel workbook

oConn.Open sConnection

' Open the recordset as a result of executing the SQL query

Set objPivotCache = ActiveWorkbook.PivotCaches.Create(xlExternal)

Set objPivotCache.Recordset = objRS

Set objRS = Nothing

Set pt = objPivotCache.CreatePivotTable(TableDestination:=rngOutput)

Set objPivotCache = Nothing

'Turn any numerical headings back to numbers by effectively removing any apostrophes in front

For Each cell In rngLeftHeaders

If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value

Next cell

For Each cell In rngRightHeaders

If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value

Next cell

With pt

.ManualUpdate = True 'stops the pt refreshing while we make chages to it.

If Application.Version >= 14 Then TabularLayout pt

For Each cell In rngLeftHeaders

With .PivotFields(cell.Value)

.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)

End With

Next cell

With .PivotFields(strCrosstabName)

.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)

End With

With .PivotFields("Total")

.Orientation = xlDataField

.Function = xlSum

End With

.ManualUpdate = False

End With

Else: MsgBox "You must first save the workbook for this code to work."

End If

unpivot = Success

timetaken = timetaken - Now()

Debug.Print "UnPivot: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")

errhandler:

If Err.Number <> 0 Then

Select Case Err.Number

Case 999: 'User pushed cancel.

Case Else: MsgBox "Whoops, there was an error: Error#" & Err.Number & vbCrLf & Err.Description _

, vbCritical, "Error", Err.HelpFile, Err.HelpContext

End Select

End If

Application.ScreenUpdating = True

End Function

Private Sub TabularLayout(pt As PivotTable)

With pt

.RepeatAllLabels xlRepeatLabels

.RowAxisLayout xlTabularRow

End With

End Sub

Filtering Pivots based on external ranges.

Posted on November 14, 2013March 17, 2018 by Jeff Weir

Howdy, folks. Jeff here again. We might as well rename this blog Daily Dose of Pivot Tables, because here’s yet another treatment of this well-worn subject this week.

Let’s say you’ve got a PivotField with 20,000 items in it. What’s the quickest way to filter that PivotTable based on an external list that contains either 100, 10000, or 19900 of those items?
The usual approach to a task like this is to just iterate through each pivotitem in the PivotItems collection, and check if that PivotItem is in the list of search terms. If it is, you make the PivotItem visible, otherwise you hide it.

But this requires us to:

Read the PivotItem name
Read in the Search Terms
Check if each PivotItem is in the list of search terms. If it is, you make the PivotItem visible, otherwise you hide it.

How long does each part of this take? Where are the bottlenecks? Let’s find out.

First, how long does it take just to iterate through all 20,000 items and get the value of each PivotItem? (Note that I’ve set pt.ManualUpdate = True before running all the following snippets, so that the PivotTable doesn’t try to update after each and every change)

For Each pi In pf.PivotItems
    strName = pi.Value 'In my test data, all items are strings
Next

For Each pi In pf.PivotItems

strName = pi.Value 'In my test data, all items are strings

Not long at all. Under a second.

How long to work out what the current visiblestatus is of each PivotItem?

For Each pi In pf.PivotItems
    bStatus = pi.Visible
Next

For Each pi In pf.PivotItems

bStatus = pi.Visible

One minute and twenty seconds? Really? Not exactly lightning fast, is it?

Okay, how long does it take to set the .Visible property of each item, without checking what it currently is? Let’s set .visible = true for each and every PivotItem (even though they are already visible) just to find out what the worst case scenario is.

For Each pi In pf.PivotItems
    pi.Visible = True
Next

For Each pi In pf.PivotItems

pi.Visible = True

Two minutes, 43 seconds. So it takes longer to set the .visible status than to read it. Handy to know.

Okay, how long will it take to first check the .Visible property of each item, and then change it?

For Each pi In pf.PivotItems
    pi.Visible = Not pi.Visible
Next

For Each pi In pf.PivotItems

pi.Visible = Not pi.Visible

Four minutes, 26 seconds. Not surprising I guess, because it’s got to first find the current state of each item – which we already established above takes around one minute and twenty seconds – and then we need to change the state – which we already established above takes around 2 minutes 43 seconds. And those two times add up to 4 minutes.

So that’s how long it would take in principle to filter the PivotTable based on the initial approach I suggested above, excluding the time taken to actually check for duplicates between the PivotItems and the search terms.

Ahhh… I hear you say (I have good ears). What if we first check whether the .visible status of a PivotItem is already set how we want it. That way, we can save some time by only changing it if it actually needs to be changed. Good point, and nice to see you’re alert.

So here’s our efficient tweak of the ‘traditional’ method:

Add all Search terms to a dictionary (or collection, if you prefer)
Try to add each PivotItem to that same dictionary.
If that last step caused an error, we’ll know that this PivotItem is in our list of search terms. In this case, we can check what the current visible status is of the PivotItem. If it’s NOT visible, we’ll make it visible. If it IS visible, we do nothing
IF this didn’t cause an error, we’ll know that this PivotItem IS NOT in our list of filter terms. In this case, we again check what the current visible status is of the PivotItem. If it’s visible, we’ll hide it. If it’s already hidden, we do nothing

So this approach is quite efficient in that it only changes the .visible status of the PivotItem if it has to. Which is good, because this is the bottleneck. And the general approach of using a Dictionary (or collection) is very efficient, compared to other ways I’ve seen on line that use say applicaiton.match to check the PivotItem against a variant array or (far worse) against the original FilterTerms range in the worksheet.

On a pivot of 20,000 items that currently has all items visible, here’s how this ‘tweaked traditional’ method performed:

It took 4:21 to filter on a list of 100 terms. When I ran it again without clearing the filter, it only took 1:32. That faster time is because it didn’t have to change the .visible status of any items at all, because they were already in the ‘correct’ state after the last run. But it still had to check them all
It took 3:03 to filter on a list of 10,000 terms. The shorter time compared to the first test case is because it only had to set the .visible status of half the pivot items. It took 1:35 when I ran it again without clearing the filter, same as before. That’s what I would expect.
It took 1:35 again to filter on a list of 19900 items – the same as the 2nd pass in the other cases, which again is what I would expect given it only had to hide a few items. And of course it took about the same time again when I ran it again without clearing the filter, same as before.

(Note that my ‘tweaked traditional’ routine has some extra checks to handle errors caused by dates in PivotFields not formatted as Date Fields, something I discussed here. And it also has to do some extra checking for PivotItems such as “1.1”, because VBA’s IsDate function interprets such a string as a date. But the extra processing time of these extra loops is pretty inconsequential compared to checking and changing the .Visible status.)

Can we do better than that?

Of course we can. What if we work out how many PivotItems in the PivotField, and how many search terms in the Search list, and either make all PivotItems visible or all PivotItems (bar one) hidden before we start, so that we minimise the amount of PivotItems we have to change the .Visible status of?

If there’s just 100 items in our Search Terms list, hide all but one PivotItem, then unhide just the 100 matching items
If there’s 19900 items in our Search Terms list, make all PivotItems visible, then hide the 100 PivotItems that are not in the Search Terms list
Because we know in advance whether all PivotItems are visible or hidden, we don’t have to check their .visible status at all.

Genius in theory, I know. And it’s certainly trivial to clear a PivotFilter so that all items are visible in that 2nd case. But that 1st case is tricky: how do you hide all but one PivotItem via VBA without iterating through and having to do all that incredibly slow .visible = false stuff? You can do it manually very easily of course. But via VBA? You can’t do it directly except if you make the field a Page Field and set .EnableMultiplePageItems to False. And then as soon as you change it to True again, VBA helpfully clears the filter so that all items are visible again. And so you’re back to square 1.

Enter the slicer

It turn out that you can very quickly hide all but one PivotItem programatically if you make a temp copy of the Pivot, make the field of interest in the temp into a Page field with .EnableMultiplePageItems set to False, and then hook it up via a slicer to your original Pivot. This forces the original PivotField to have the same filter setting – just one item visible. But it doesn’t make that original Pivot have the same layout. So the original pivot can still be say a Row field where you can then merrily make additional items visible.

How fast is this approach? Very. Again, using a test pivot with 20,000 items in it:

Filter on 100 search terms: 0:05 (compared with 4:21 in the approach above)
Filter on 10,000 search terms: 1:26 (compared with 3:03 in the approach above)
Filter on 19,900 search terms: 0:03 (compared with 1:35 in the approach above)

Now that is some improvement.

Here’s the two routines below for your viewing pleasure. I turned both routines into functions, which you call by a wrapper. This lets you pre-specify what PivotField you want to filter and where your search terms are. Otherwise you’ll be prompted to select them via some input boxes.

Also check out the attached workbook that has the code inside, and that lets you generate random alphanumeric PivotFields and Search Terms in a jiffy (something I’ll cover in a future post). Just click the Create Sample Data button after changing the input parameters, and then click on the command button of choice. When you run the code from the command buttons, the times of each pass will be recorded in the workbook too, so you can compare different settings.

Filter PivotTable 20131114

Have at it people. Look forward to comments, feedback, suggestions, and Nobel Prize nominations.

Regards,
Jeff

Slower Approach

Sub Dictionary_Slower()
FilterPivot_Dictionary_Slower
End Sub


Private Function FilterPivot_Dictionary_Slower(Optional rngPivotField As Range, Optional rngFilterItems As Range) As Boolean
' Copyright ©2013 Jeff Weir
' weir.jeff@gmail.com
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' ---------------------------------------------------------------------

'   Date        Initial     Details                 Version
'   20131113    JSW         Initial Programming     007 (of course)
 
'#############
'#  Remarks  #
'#############

'   This code needs to be called by a wrapper function.
'   e.g.

'    Sub FilterPivot()
'    FilterPivot_Dictionary_Slower
'    End Sub

'   If required, that wrapper function can also provide ranges
'   specifying what PivotField to filter, and where the range of
'   filter terms is. e.g.:
'       FilterPivot_Dictionary_Slower Range("A2"), Range("C2:C20000")
'   ...or
'       FilterPivot_Dictionary_Slower(ActiveCell, [tblFilterItems])



    Dim ptOriginal As PivotTable
    Dim pfOriginal As PivotField
    Dim pfFilterItems As PivotField
    Dim pi As PivotItem
    Dim ptFilterItems As PivotTable
    Dim wksTemp As Worksheet
    Dim wksPivot As Worksheet
    Dim dic As Object
    Dim varContinue As Variant
    Dim strMessage As String
    Dim varFormat As Variant
    Dim bDateFormat As Boolean
    Dim bDateWarning As Boolean
    
   
    FilterPivot_Dictionary_Slower = False   'Assume failure

    On Error GoTo ErrHandler
    Set wksPivot = ActiveSheet

    'If neccessary, prompt user for the pivotfield of interest
    If rngPivotField Is Nothing Then
        On Error Resume Next
        Set rngPivotField = ActiveCell
        Set pfOriginal = rngPivotField.PivotField    'Tests if this is in fact a PivotField
        If Err <> 0 Then
            Err.Clear
            Set rngPivotField = Nothing
            Set rngPivotField = Application.InputBox( _
                                Title:="Where is the PivotField?", _
                                Prompt:="Please select a cell in the PivotField you want to filter", _
                                Type:=8)
            On Error GoTo ErrHandler
            If rngPivotField Is Nothing Then Err.Raise 996
        End If
        On Error GoTo ErrHandler
    End If

    Set pfOriginal = rngPivotField.PivotField
    Set ptOriginal = pfOriginal.Parent


    'If neccessary, prompt user for FilterItems table related to the pivotfield of interest
    If rngFilterItems Is Nothing Then
        On Error Resume Next
        Set rngFilterItems = Application.InputBox( _
                             Title:="Where are the filter items?", _
                             Prompt:="Please select the range where your filter terms are", _
                             Type:=8)
        On Error GoTo ErrHandler
        If rngFilterItems Is Nothing Then Err.Raise 996
    End If
    
    
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Excel stores dates differently between PivotItems and Variant Arrays.
    
    ' For instance:
    '    ? CStr(varFilterItems(i, 1))
    '    1/01/2013
    '    ? pi.Value
    '    1/1/2013
    '    ? CStr(varFilterItems(i, 1)) = pi.Value
    '    False

    'So we 'll turn our FilterItems into a PivotTable to ensure formats are treated the same.

    Set wksTemp = Sheets.Add
    rngFilterItems.Copy wksTemp.Range("A2")
    wksTemp.Range("A1").Value = "FilterItems"
    Set rngFilterItems = wksTemp.Range("A2").CurrentRegion
    
On Error GoTo 0

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        rngFilterItems).CreatePivotTable _
        TableDestination:=[C1], TableName:="appFilterItems"
          
    Set ptFilterItems = wksTemp.PivotTables("appFilterItems")
    Set pfFilterItems = ptFilterItems.PivotFields(1)

     ' Add FILTERItems to a Dictionary
        Set dic = CreateObject("scripting.dictionary")
        For Each pi In pfFilterItems.PivotItems
            dic.Add pi.Value, 1  'The one does nothing
        Next

    ptOriginal.ManualUpdate = True  'dramatically speeds up the routine, because the pivot won't recalculate until we're done

        
    'Check if PFOriginal is formatted as a date field.
    ' Basically there is a bug in Excel whereby if you try to do some things
    ' to a PivotItem containing a date but the PivotField number format is NOT a date format
    ' then you get an error.
    ' So we'll check the PivotField date format and see what it is
    ' Note that if a PivotField is based on a range that contains multiple formats
    ' then you get an error simply by checking what the PivotField number format is.
    ' So we'll instigate an On Error Resume Next to handle this
    
    On Error Resume Next
    varFormat = pfOriginal.NumberFormat
    On Error GoTo ErrHandler
    If IsDate(Format(1, varFormat)) Then bDateFormat = True
    
        
        ' Now try and add the PivotItems.
        ' If ther's an error, we'll know that this item is also in the FilterTerms
        On Error Resume Next
        With dic
            For Each pi In pfOriginal.PivotItems
                dic.Add pi.Value, 1 'The 1 does nothing
                If Err.Number <> 0 Then
                    'This item exists in our search term list, so we should unhide it
                    'Note that IF this item is a date but the PivotField format is NOT a date format,
                    ' we can't programatically hide/show items, so we'll have to check this first
                    If Not bDateFormat Then
                        If Not IsNumeric(pi.Value) Then
                            'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates
                            If IsDate(pi.Value) Then
                                If Not bDateWarning Then
                                    On Error GoTo ErrHandler
                                    Err.Raise Number:=997, Description:="Can't filter dates"
                                    On Error Resume Next
                                End If
                            Else:
                                If Not pi.Visible = True Then pi.Visible = True
                            End If
                        Else: If Not pi.Visible = True Then pi.Visible = True
                        End If
                    Else: If Not pi.Visible = True Then pi.Visible = True
                    End If
                    Err.Clear
                Else: If Not pi.Visible = False Then pi.Visible = False
                End If
            Next
        End With

   
    On Error GoTo ErrHandler
    FilterPivot_Dictionary_Slower = True

ErrHandler:
    If Err.Number <> 0 Then
        Select Case Err.Number
        Case Is = 0:    'No error - do nothing
        Case Is = 996:    'Operation Cancelled
        Case Is = 997:    'Can't filter dates
            strMessage = "*** WARNING...I can't correctly filter dates in this Pivot ***"
            strMessage = strMessage & vbNewLine & vbNewLine
            strMessage = strMessage & "I've found at least one date in this PivotField. "
            strMessage = strMessage & "Unfortunately due to a bug in Excel, if you have dates "
            strMessage = strMessage & " in a PivotField AND that PivotField is NOT formatted "
            strMessage = strMessage & " with a date format, then dates "
            strMessage = strMessage & " can't be programatically filtered either in or out. "
            strMessage = strMessage & vbNewLine & vbNewLine
            strMessage = strMessage & " So you'll have to manually check to see whether "
            strMessage = strMessage & " date items appear as they should."
            strMessage = strMessage & vbNewLine & vbNewLine
            strMessage = strMessage & "Do you want me to continue anyway? "
            varContinue = MsgBox(Prompt:=strMessage, Buttons:=vbYesNo, Title:="Sorry, can't filter dates")
            If varContinue = 6 Then
                bDateWarning = True
                Resume Next
            Else: pfOriginal.ClearAllFilters
            End If
        Case Is = 998:    'Can't filter Datafields
            MsgBox "Oops, you can't filter a DataField." & vbNewLine & vbNewLine & "Please select a RowField, dicumnField, or PageField and try again.", vbCritical, "Can't filter Datafields"
        Case Is = 999:    'no pivotfield selected
            MsgBox "Oops, you haven't selected a pivotfield." & vbNewLine & vbNewLine & "Please select a RowField, dicumnField, or PageField and try again.", vbCritical, "No PivotField selected"
        Case Else:
            MsgBox "Whoops, something went wrong"
        End Select
    End If

    With Application
        If Not wksTemp Is Nothing Then
            .DisplayAlerts = False
            wksTemp.Delete
            .DisplayAlerts = True
        End If
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    If Not ptOriginal Is Nothing Then ptOriginal.ManualUpdate = False

End Function

<h2>Faster Approach</h2>

Option Explicit

'Further Development Ideas
'   Date        Ini     Detail
'    20150605    JSW    Colud potentially enhance the handling of dates in GENERAL formatted PivotFields by checking if format matches the US date layout.
'                       See http://www.vbforums.com/showthread.php?287517-Determining-regional-setting-in-VBA-code
'                       ALso, there's a potential workaround at http://dailydoseofexcel.com/archives/2013/11/09/a-date-with-pivotitems/#comment-638479


Sub FilterPivot()
'   Description:    Wrapper function for my FilterPivot Function
'                   (Required in the event that a user wants to trigger the FilterPivot
'                   function and specify parameters at runtime, instead of programatiacally
'                   calling the routine)
'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

'   Name/Version:   Date:       Ini:   Modification:
'   FilterPivot     20150305    JSW    Initial programming

FilterPivot_Routine
End Sub

Sub FilterPivot_Inverse()
'   Description:    Wrapper function for my FilterPivot_Inverse Function
'                   (Required in the event that a user wants to trigger the FilterPivot_Inverse
'                   function and specify parameters at runtime, instead of programatiacally
'                   calling the routine)
'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

'   Name/Version:       Date:       Ini:   Modification:
'   FilterPivot_Inverse 20150305    JSW    Initial programming
FilterPivot_Routine bInverse:=True
End Sub


Function FilterPivot_AddRightClick()
   
'   Description:    Adds  "Filter Pivotfield" shortcuts to PivotTable right-click menu
'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

'   Name/Version:   Date:       Ini:   Modification:
'   AddShortcuts    20150305    JSW    Initial programming

    Dim cbr As CommandBar
    Dim sMessage As String
    FilterPivot_RemoveRightClick
    Set cbr = Application.CommandBars("PivotTable Context Menu")

    With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)
        .Caption = "Filter Pivotfield"
        .Tag = "FilterPivotField"
        .OnAction = "FilterPivot"
        .Style = msoButtonIconAndCaption
        .Picture = Application.CommandBars.GetImageMso("FilterAdvancedByForm", 16, 16)
    End With
    With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)
        .Caption = "Inversely Filter Pivotfield"
        .Tag = "FilterPivotField"
        .OnAction = "FilterPivot_Inverse"
        .Style = msoButtonIconAndCaption
        .Picture = Application.CommandBars.GetImageMso("FilterAdvancedMenu", 16, 16)
    End With


    
End Function

Function FilterPivot_RemoveRightClick()
   
'   Description:    Removes  "Filter Pivotfield" shortcuts from PivotTable right-click menu
'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

'   Name/Version:   Date:       Ini:   Modification:
'   AddShortcuts    20150305    JSW    Initial programming

    Dim cbr As CommandBar
    Dim sMessage As String
    Dim ctrl As CommandBarControl
    
    
    Set cbr = Application.CommandBars("PivotTable Context Menu")
    For Each ctrl In cbr.Controls
        If ctrl.Tag = "FilterPivotField" Then ctrl.Delete
    Next


    
End Function


Private Function FilterPivot_Slicers(ptTemp As PivotTable, pfTemp As PivotField, ptOriginal As PivotTable)
Dim sc As SlicerCache
' This sub-function contains code that requires Slicers
' It's in this stand-alone function, becaues it only gets called if user has Excel 2010 or later
' If it was incorporated DIRECTY within the FilterPivot function, that function wouldn't compile on pre 2010 machines

    Set sc = ActiveWorkbook.SlicerCaches.Add(ptTemp, pfTemp)
    sc.PivotTables.AddPivotTable ptOriginal
    'Great, our original pivot now just has one item visible in the field of interest
    'So we can delete the slicer connection
    sc.Delete
End Function


Private Function FilterPivot_Routine(Optional rngPivotField As Range, Optional rngFilterItems As Range, Optional bInverse As Boolean = False) As Boolean
' Copyright ©2013 Jeff Weir
' weir.jeff@gmail.com
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' ---------------------------------------------------------------------

'   Date        Initial     Version Details

'   20131113    JSW         007     Initial Programming
'   20131203    JSW         008     Added Inverse Option
'   20140503    JSW         009     Changed so works in pre Excel 2010
'   20140503    JSW         010     Changed so pi.format check not performed in Excel 2013 +
'   20150223    JSW         011     Added check to ensure pfOriginal has .EnableMultiplePageItems set to TRUE if it is a pagefield.
'   20150429    JSW         012     Turned off events, cleared pfOriginal filter.
'   20150605    JSW         013     Fixed “Save source data with file” reset as per http://dailydoseofexcel.com/archives/2013/11/14/filtering-pivots-based-on-external-ranges/#comment-787682


 
'#############
'#  Remarks  #
'#############

'   This code needs to be called by a wrapper function.
'   e.g.

'   Sub FilterPivot()
'    FilterPivot_Routine
'    End Sub

'    Sub FilterPivot_Inverse()
'    FilterPivot_Routine bInverse:=True
'    End Sub

'   If required, that wrapper function can also provide ranges
'   specifying what PivotField to filter, and where the range of
'   filter terms is. e.g.:
'       FilterPivot_Routine  Range("A2"), Range("C2:C20000")
'   ...or
'       FilterPivot_Routine  ActiveCell, [tblFilterItems]



    Dim ptOriginal As PivotTable
    Dim ptTemp As PivotTable
    Dim pfOriginal As PivotField
    Dim pfTemp As PivotField
    Dim pfFilterItems As PivotField
    Dim lngFilterItems As Long
    Dim pi As PivotItem
    Dim ptFilterItems As PivotTable
    Dim wksTemp As Worksheet
    Dim wksPivot As Worksheet
    Dim dic As Object
    Dim varContinue As Variant
    Dim strMessage As String
    Dim varFormat As Variant
    Dim bDateFormat As Boolean
    Dim bDateWarning As Boolean
    Dim bFirstItemVisible As Boolean
    Dim varFirstItemVisible As Variant
    Dim bEnableEvents As Boolean
    Dim bScreenUpdating As Boolean
    Dim lngCalculation As Long
    Dim bSaveDataState As Boolean
    

    FilterPivot_Routine = False   'Assume failure

    On Error GoTo errhandler
    Set wksPivot = ActiveSheet

    'If neccessary, prompt user for the pivotfield of interest
    If rngPivotField Is Nothing Then
        On Error Resume Next
        Set rngPivotField = ActiveCell
        Set pfOriginal = rngPivotField.PivotField    'Tests if this is in fact a PivotField
        If Err <> 0 Then
            Err.Clear
            Set rngPivotField = Nothing
            Set rngPivotField = Application.InputBox( _
                                Title:="Where is the PivotField?", _
                                Prompt:="Please select a cell in the PivotField you want to filter", _
                                Type:=8)
            On Error GoTo errhandler
            If rngPivotField Is Nothing Then Err.Raise 996
        End If
        On Error GoTo errhandler
    End If

    Set pfOriginal = rngPivotField.PivotField
    Set ptOriginal = pfOriginal.Parent
    
    'Capture the SaveData state of the original pivot table
    bSaveDataState = ptOriginal.SaveData
    
    With pfOriginal
        If .Orientation = xlPageField Then
            If .EnableMultiplePageItems = False Then
                .EnableMultiplePageItems = True
                .ClearAllFilters
            End If
        End If
    End With

    'If neccessary, prompt user for FilterItems table related to the pivotfield of interest
    If rngFilterItems Is Nothing Then
        On Error Resume Next
        Set rngFilterItems = Application.InputBox( _
                             Title:="Where are the filter items?", _
                             Prompt:="Please select the range where your filter terms are.", _
                             Type:=8)
        On Error GoTo errhandler
        If rngFilterItems Is Nothing Then Err.Raise 996
    End If

    With Application
        bScreenUpdating = .ScreenUpdating
        bEnableEvents = .EnableEvents
        lngCalculation = .Calculation
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

   
    ' Excel stores dates differently between PivotItems and Variant Arrays.
   
    ' For instance:
    '    ? CStr(varFilterItems(i, 1))
    '    1/01/2013
    '    ? pi.Value
    '    1/1/2013
    '    ? CStr(varFilterItems(i, 1)) = pi.Value
    '    False

    'So we 'll turn our FilterItems into a PivotTable to ensure formats are treated the same.

    Set wksTemp = Sheets.Add
    rngFilterItems.Copy wksTemp.Range("A2")
    wksTemp.Range("A1").Value = "FilterItems"
    Set rngFilterItems = wksTemp.Range("A2").CurrentRegion
   
    On Error GoTo errhandler

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        rngFilterItems).CreatePivotTable _
        TableDestination:=[C1], TableName:="appFilterItems"
         
    Set ptFilterItems = wksTemp.PivotTables("appFilterItems")
    Set pfFilterItems = ptFilterItems.PivotFields(1)

     ' Add FILTERItems to a Dictionary
    Set dic = CreateObject("scripting.dictionary")
    For Each pi In pfFilterItems.PivotItems
        dic.Add pi.Value, 1 'The one does nothing
    Next

   ptOriginal.ManualUpdate = True  'dramatically speeds up the routine, because the pivot won't recalculate until we're done

       
    'Check if we're dealing with Excel 2010 or earlier and if PFOriginal is formatted as a date field.
    ' Basically there is a bug in Excel 2010 or earlier whereby if you try to do some things
    ' to a PivotItem containing a date but the PivotField number format is NOT a date format
    ' then you get an error.
    ' So we'll check the PivotField date format and see what it is
    ' Note that if a PivotField is based on a range that contains multiple formats
    ' then you get an error simply by checking what the PivotField number format is.
    ' So we'll instigate an On Error Resume Next to handle this
    
    If Application.Version < 15 Then
        On Error Resume Next
        varFormat = pfOriginal.NumberFormat
        On Error GoTo errhandler
        If IsDate(Format(1, varFormat)) Then bDateFormat = True
    End If
   
    'Work out maximum amount of filteritems under bInverse scenario
    If bInverse Then
        lngFilterItems = pfOriginal.PivotItems.Count - rngFilterItems.Count
    Else: lngFilterItems = rngFilterItems.Count
    End If
   
    If lngFilterItems / pfOriginal.PivotItems.Count < 0.5 And Application.Version >= 14 Then
    
        '====================================================================================
        ' If it's likely that less than half of the source Pivot Field's
        ' items will be visible when we're done, then it will be quickest to hide all but one
        ' item and then unhide the PivotItems that match the filter terms
        
        ' Iterating through a large pivot setting all but one item to hidden is slow.
        ' And there's no way to directly do this except in Page Fields, and
        ' that method doesn't let you select multiple items anyway.
        ' Plus, as soon as you drag a page field with just one item showing to
        ' a row field, Excel clears the filter, so that all items are visible again.

        ' So we'll use a trick:
        '  *  make the pf of interest in ptTemp a page field
        '  *  turn off multiple items and select just one PivotItem
        '  *  connect it to the original pivot with a slicer
        ' This will very quickly sync up the field on the original pivot so that only one field is showing.
        
        ' NOTE: WE CAN ONLY DO THIS IF USING EXCEL 2010 OR LATER using the below approach.
        ' If earlier version, we'll use the approach outlined in the ELSE part of this IF block.
        
        ' ALSO NOTE: If a PivotField has a non-Date format, but contains dates, then
        ' we can't programatically hide/show items. So we need to check for this.
        '====================================================================================


        'Identify a suitable item with which to filter the original PivotTable with
        ' As per note above,
        '  *  If the PivotField format is NOT a date format,
        '     then we need to make sure that this first item is NOT a date.
        '     ...because otherwise we can't address it by VBA
        '  *  If the PivotFied format IS a date format, then just use the first item.
        '  *  We'll write that item to a range, then to a variant, so that Excel applies the
        '     same format to it as it does to items in our Filter list
        
        If Not bDateFormat Then
            For Each pi In pfOriginal.PivotItems
                If IsDate(pi.Value) Then
                    If IsNumeric(pi.Value) Then
                        'We need the IsNumeric bit above because
                        'VBA thinks that some decimals encased in strings e.g. "1.1" are dates
                        'So we need to check whether this is a decimal and NOT a date
                        varFirstItemVisible = pi.Value
                        Exit For
                    Else:
                        If Not bDateWarning Then
                            Err.Raise Number:=997, Description:="Can't filter dates"
                        End If
                    End If
                Else:
                    varFirstItemVisible = pi.Value
                    Exit For
                End If
            Next
        Else:
            varFirstItemVisible = pfOriginal.PivotItems(1).Value
        End If
       
        Set ptTemp = ptOriginal.PivotCache.CreatePivotTable(TableDestination:=wksTemp.Range("F1"))
        Set pfTemp = ptTemp.PivotFields(pfOriginal.SourceName)
        
        'Set the SaveData state the same as the original pivot table in case it is set to False
        'When creating a new pivot table, by default it is set to True, which will carry over to the original pivot table
        ptTemp.SaveData = bSaveDataState
       
        With pfTemp
            .Orientation = xlPageField
            .ClearAllFilters
            .EnableMultiplePageItems = False
            .CurrentPage = pfTemp.PivotItems(varFirstItemVisible).Value
        End With

        Call FilterPivot_Slicers(ptTemp, pfTemp, ptOriginal)

        ' Check if FirstItemVisible should be visible or hidden when we are done
       If dic.Exists(varFirstItemVisible) Then bFirstItemVisible = True

       
        ' Now try and add the PivotItems.
        ' If there's an error, we'll know that this item is also in the FilterTerms
        On Error Resume Next
        With dic
        
        'The Not bInverse bit in the code blocks below effectively 'flip' the test "If Err.Number <> 0" to "If Err.Number = 0"
        'in the case that bInverse argument is TRUE (meaning we want the Pivot to be filtered on things
        ' NOT in the list of search terms)
        
            If Application.Version >= 15 Then
                For Each pi In pfOriginal.PivotItems
                      dic.Add pi.Value, 1 'The 1 does nothing
                      If Err.Number <> 0 = Not bInverse Then
                        pi.Visible = True
                    End If
                        Err.Clear
                Next
            Else:   'There's a bug in previous versions where you can't use .Visible for dates
                    'if the PivotField is set to General format.
                For Each pi In pfOriginal.PivotItems
                    dic.Add pi.Value, 1 'The 1 does nothing
                    If Err.Number <> 0 = Not bInverse Then
                        ' This item exists in our search term list, so we should unhide it
                        ' Note that due to a bug in Excel 2010, if this item is a date
                        ' but the PivotField format is NOT a date format, we can't
                        ' programatically hide/show items, so we'll have to check this first
                        If Not bDateFormat Then
                            If Not IsNumeric(pi.Value) Then
                                'We need the Not IsNumeric bit above because VBA thinks that
                                ' some decimals encased in strings e.g."1.1" are dates
                                If IsDate(pi.Value) Then
                                    If Not bDateWarning Then
                                        On Error GoTo errhandler
                                        Err.Raise Number:=997, Description:="Can't filter dates"
                                        On Error Resume Next
                                    End If
                                Else: pi.Visible = True
                                End If
                            Else: pi.Visible = True
                            End If
                        Else: pi.Visible = True
                        End If
                    End If
                    Err.Clear
                Next
            End If 'If Application.Version >= 15 Then
            
        End With

        If Not bFirstItemVisible = Not bInverse Then
            pfOriginal.PivotItems(varFirstItemVisible).Visible = False
            If Err.Number <> 0 Then
                MsgBox "None of the filter items were found in the Pivot"
                pfOriginal.ClearAllFilters
                Err.Clear
            End If
        End If

    Else:
        ' If it's likely that MORE than half of the source Pivot Field's items will be visible
        ' when we're done, then it's quickest to unhide all PivotItems and then hide the
        ' PivotItems that DON'T match the filter terms
        
        pfOriginal.ClearAllFilters

        ' Now try and add the PivotItems.
        ' If there's an error, we'll know that this item is in the FilterItems
        ' Otherwise we'll hide it
       
        On Error Resume Next
        With dic
            If Application.Version >= 15 Then 'Excel 2010 and earier have some 'issues' with dates
                For Each pi In pfOriginal.PivotItems
                    dic.Add pi.Value, 1 'The 1 does nothing
                    If Err.Number = 0 = Not bInverse Then pi.Visible = False
                    Err.Clear
                Next
            Else:
                 For Each pi In pfOriginal.PivotItems
                    dic.Add pi.Value, 1 'The 1 does nothing
                    If Err.Number = 0 = Not bInverse Then
                        'The Not bInverse bit effectively 'flips' the test "If Err.Number = 0" to "If Err.Number <> 0"
                        'in the case that bInverse argument is TRUE (meaning we want the Pivot to be filtered on things
                        ' NOT in the list of search terms)
                        
                        'This PivotItem NOT in FilterItems list. So hide it
                        'Note that IF this item is a date but the PivotField format is NOT a date format,
                        ' then we can't programatically hide/show items, so we'll have to check this first
                        If Not bDateFormat Then
                            If Not IsNumeric(pi.Value) Then
                                'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates
                                If IsDate(pi.Value) Then
                                    If Not bDateWarning Then
                                        On Error GoTo errhandler
                                        Err.Raise Number:=997, Description:="Can't filter dates"
                                        On Error Resume Next
                                    End If
                                Else: pi.Visible = False 'This item does not exist in the FilterItems. So hide it
                                End If
                            Else: pi.Visible = False 'This item does not exist in the FilterItems. So hide it
                            End If
                        Else: pi.Visible = False
                        End If
                    End If
                    Err.Clear
                Next
            End If 'If Application.Version >= 15 Then
        End With
        
    End If 'If lngFilterItems / pfOriginal.PivotItems.Count < 0.5 And Application.Version >= 14 Then
    On Error GoTo errhandler
    FilterPivot_Routine = True

errhandler:
    If Err.Number <> 0 Then
        Select Case Err.Number
        Case Is = 0:    'No error - do nothing
        Case Is = 996:    'Operation Cancelled
        Case Is = 997:    'Can't filter dates
            strMessage = "*** WARNING...I can't correctly filter dates in this Pivot ***"
            strMessage = strMessage & vbNewLine & vbNewLine
            strMessage = strMessage & "I've found at least one date in this PivotField. "
            strMessage = strMessage & "Unfortunately due to a bug in Excel, if you have dates "
            strMessage = strMessage & " in a PivotField AND that PivotField is NOT formatted "
            strMessage = strMessage & " with a date format, then dates "
            strMessage = strMessage & " can't be programatically filtered either in or out. "
            strMessage = strMessage & vbNewLine & vbNewLine
            strMessage = strMessage & " So you'll have to manually check to see whether "
            strMessage = strMessage & " date items appear as they should."
            strMessage = strMessage & vbNewLine & vbNewLine
            strMessage = strMessage & "Do you want me to continue anyway? "
            varContinue = MsgBox(Prompt:=strMessage, Buttons:=vbYesNo, Title:="Sorry, can't filter dates")
            If varContinue = 6 Then
                bDateWarning = True
                Resume Next
            Else: pfOriginal.ClearAllFilters
            End If
        Case Is = 998:    'Can't filter Datafields
            MsgBox "Oops, you can't filter a DataField." & vbNewLine & vbNewLine & "Please select a RowField, ColumnField, or PageField and try again.", vbCritical, "Can't filter Datafields"
        Case Is = 999:    'no pivotfield selected
            MsgBox "Oops, you haven't selected a pivotfield." & vbNewLine & vbNewLine & "Please select a RowField, ColumnField, or PageField and try again.", vbCritical, "No PivotField selected"
        Case Else:
            MsgBox "Whoops, something went wrong"
        End Select
    End If

    With Application
        If Not wksTemp Is Nothing Then
            .DisplayAlerts = False
            wksTemp.Delete
            .DisplayAlerts = True
        End If
        .ScreenUpdating = bScreenUpdating
        .EnableEvents = bEnableEvents
        .Calculation = lngCalculation

    End With
    If Not ptOriginal Is Nothing Then ptOriginal.ManualUpdate = False

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

408

409

410

411

412

413

414

415

416

417

418

419

420

421

422

423

424

425

426

427

428

429

430

431

432

433

434

435

436

437

438

439

440

441

442

443

444

445

446

447

448

449

450

451

452

453

454

455

456

457

458

459

460

461

462

463

464

465

466

467

468

469

470

471

472

473

474

475

476

477

478

479

480

481

482

483

484

485

486

487

488

489

490

491

492

493

494

495

496

497

498

499

500

501

502

503

504

505

506

507

508

509

510

511

512

513

514

515

516

517

518

519

520

521

522

523

524

525

526

527

528

529

530

531

532

533

534

535

536

537

538

539

540

541

542

543

544

545

546

547

548

549

550

551

552

553

554

555

556

557

558

559

560

561

562

563

564

565

566

567

568

569

570

571

572

573

574

575

576

577

578

579

580

581

582

583

584

585

586

587

588

589

590

591

592

593

594

595

596

597

598

599

600

601

602

603

604

605

606

607

608

609

610

611

612

613

614

615

616

617

618

619

620

621

622

623

624

625

626

627

628

629

630

631

632

633

634

635

636

637

638

639

640

641

642

643

644

645

646

647

648

649

650

651

652

653

654

655

656

657

658

659

660

661

662

663

664

665

666

667

668

669

670

671

672

673

674

675

676

677

678

679

680

681

682

683

684

685

686

687

688

689

690

691

692

693

694

695

696

697

698

699

700

701

702

703

704

705

706

707

708

709

710

711

712

713

714

715

716

717

718

719

720

721

722

723

724

725

726

727

728

729

730

731

732

733

734

735

736

737

738

739

740

741

742

743

744

745

746

747

748

749

750

751

752

753

754

755

756

757

758

759

760

761

762

763

Sub Dictionary_Slower()

FilterPivot_Dictionary_Slower

End Sub

Private Function FilterPivot_Dictionary_Slower(Optional rngPivotField As Range, Optional rngFilterItems As Range) As Boolean

' weir.jeff@gmail.com

' You are free to use this code within your own applications, add-ins,

' documents etc but you are expressly forbidden from selling or

' otherwise distributing this source code without prior consent.

' This includes both posting free demo projects made from this

' code as well as reproducing the code in text or html format.

' ---------------------------------------------------------------------

' Date Initial Details Version

' 20131113 JSW Initial Programming 007 (of course)

'#############

'# Remarks #

'#############

' This code needs to be called by a wrapper function.

' e.g.

' Sub FilterPivot()

' FilterPivot_Dictionary_Slower

' End Sub

' If required, that wrapper function can also provide ranges

' specifying what PivotField to filter, and where the range of

' filter terms is. e.g.:

' FilterPivot_Dictionary_Slower Range("A2"), Range("C2:C20000")

' ...or

' FilterPivot_Dictionary_Slower(ActiveCell, [tblFilterItems])

Dim ptOriginal As PivotTable

Dim pfOriginal As PivotField

Dim pfFilterItems As PivotField

Dim pi As PivotItem

Dim ptFilterItems As PivotTable

Dim wksTemp As Worksheet

Dim wksPivot As Worksheet

Dim dic As Object

Dim varContinue As Variant

Dim strMessage As String

Dim varFormat As Variant

Dim bDateFormat As Boolean

Dim bDateWarning As Boolean

FilterPivot_Dictionary_Slower = False 'Assume failure

On Error GoTo ErrHandler

Set wksPivot = ActiveSheet

'If neccessary, prompt user for the pivotfield of interest

If rngPivotField Is Nothing Then

On Error Resume Next

Set rngPivotField = ActiveCell

Set pfOriginal = rngPivotField.PivotField 'Tests if this is in fact a PivotField

If Err <> 0 Then

Err.Clear

Set rngPivotField = Nothing

Set rngPivotField = Application.InputBox( _

Title:="Where is the PivotField?", _

Prompt:="Please select a cell in the PivotField you want to filter", _

Type:=8)

On Error GoTo ErrHandler

If rngPivotField Is Nothing Then Err.Raise 996

End If

On Error GoTo ErrHandler

End If

Set pfOriginal = rngPivotField.PivotField

Set ptOriginal = pfOriginal.Parent

'If neccessary, prompt user for FilterItems table related to the pivotfield of interest

If rngFilterItems Is Nothing Then

On Error Resume Next

Set rngFilterItems = Application.InputBox( _

Title:="Where are the filter items?", _

Prompt:="Please select the range where your filter terms are", _

Type:=8)

On Error GoTo ErrHandler

If rngFilterItems Is Nothing Then Err.Raise 996

End If

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

' Excel stores dates differently between PivotItems and Variant Arrays.

' For instance:

' ? CStr(varFilterItems(i, 1))

' 1/01/2013

' ? pi.Value

' 1/1/2013

' ? CStr(varFilterItems(i, 1)) = pi.Value

' False

'So we 'll turn our FilterItems into a PivotTable to ensure formats are treated the same.

Set wksTemp = Sheets.Add

rngFilterItems.Copy wksTemp.Range("A2")

wksTemp.Range("A1").Value = "FilterItems"

Set rngFilterItems = wksTemp.Range("A2").CurrentRegion

On Error GoTo 0

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _

rngFilterItems).CreatePivotTable _

TableDestination:=[C1], TableName:="appFilterItems"

Set ptFilterItems = wksTemp.PivotTables("appFilterItems")

Set pfFilterItems = ptFilterItems.PivotFields(1)

' Add FILTERItems to a Dictionary

Set dic = CreateObject("scripting.dictionary")

For Each pi In pfFilterItems.PivotItems

dic.Add pi.Value, 1 'The one does nothing

ptOriginal.ManualUpdate = True 'dramatically speeds up the routine, because the pivot won't recalculate until we're done

'Check if PFOriginal is formatted as a date field.

' Basically there is a bug in Excel whereby if you try to do some things

' to a PivotItem containing a date but the PivotField number format is NOT a date format

' then you get an error.

' So we'll check the PivotField date format and see what it is

' Note that if a PivotField is based on a range that contains multiple formats

' then you get an error simply by checking what the PivotField number format is.

' So we'll instigate an On Error Resume Next to handle this

On Error Resume Next

varFormat = pfOriginal.NumberFormat

On Error GoTo ErrHandler

If IsDate(Format(1, varFormat)) Then bDateFormat = True

' Now try and add the PivotItems.

' If ther's an error, we'll know that this item is also in the FilterTerms

On Error Resume Next

With dic

For Each pi In pfOriginal.PivotItems

dic.Add pi.Value, 1 'The 1 does nothing

If Err.Number <> 0 Then

'This item exists in our search term list, so we should unhide it

'Note that IF this item is a date but the PivotField format is NOT a date format,

' we can't programatically hide/show items, so we'll have to check this first

If Not bDateFormat Then

If Not IsNumeric(pi.Value) Then

'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates

If IsDate(pi.Value) Then

If Not bDateWarning Then

On Error GoTo ErrHandler

Err.Raise Number:=997, Description:="Can't filter dates"

On Error Resume Next

End If

Else:

If Not pi.Visible = True Then pi.Visible = True

End If

Else: If Not pi.Visible = True Then pi.Visible = True

End If

Else: If Not pi.Visible = True Then pi.Visible = True

End If

Err.Clear

Else: If Not pi.Visible = False Then pi.Visible = False

End If

End With

On Error GoTo ErrHandler

FilterPivot_Dictionary_Slower = True

ErrHandler:

If Err.Number <> 0 Then

Select Case Err.Number

Case Is = 0: 'No error - do nothing

Case Is = 996: 'Operation Cancelled

Case Is = 997: 'Can't filter dates

strMessage = "*** WARNING...I can't correctly filter dates in this Pivot ***"

strMessage = strMessage & vbNewLine & vbNewLine

strMessage = strMessage & "I've found at least one date in this PivotField. "

strMessage = strMessage & "Unfortunately due to a bug in Excel, if you have dates "

strMessage = strMessage & " in a PivotField AND that PivotField is NOT formatted "

strMessage = strMessage & " with a date format, then dates "

strMessage = strMessage & " can't be programatically filtered either in or out. "

strMessage = strMessage & vbNewLine & vbNewLine

strMessage = strMessage & " So you'll have to manually check to see whether "

strMessage = strMessage & " date items appear as they should."

strMessage = strMessage & vbNewLine & vbNewLine

strMessage = strMessage & "Do you want me to continue anyway? "

varContinue = MsgBox(Prompt:=strMessage, Buttons:=vbYesNo, Title:="Sorry, can't filter dates")

If varContinue = 6 Then

bDateWarning = True

Resume Next

Else: pfOriginal.ClearAllFilters

End If

Case Is = 998: 'Can't filter Datafields

MsgBox "Oops, you can't filter a DataField." & vbNewLine & vbNewLine & "Please select a RowField, dicumnField, or PageField and try again.", vbCritical, "Can't filter Datafields"

Case Is = 999: 'no pivotfield selected

MsgBox "Oops, you haven't selected a pivotfield." & vbNewLine & vbNewLine & "Please select a RowField, dicumnField, or PageField and try again.", vbCritical, "No PivotField selected"

Case Else:

MsgBox "Whoops, something went wrong"

End Select

End If

With Application

If Not wksTemp Is Nothing Then

.DisplayAlerts = False

wksTemp.Delete

.DisplayAlerts = True

End If

.ScreenUpdating = True

.Calculation = xlCalculationAutomatic

End With

If Not ptOriginal Is Nothing Then ptOriginal.ManualUpdate = False

End Function

<h2>Faster Approach</h2>

Option Explicit

'Further Development Ideas

' Date Ini Detail

' 20150605 JSW Colud potentially enhance the handling of dates in GENERAL formatted PivotFields by checking if format matches the US date layout.

' See http://www.vbforums.com/showthread.php?287517-Determining-regional-setting-in-VBA-code

' ALso, there's a potential workaround at http://dailydoseofexcel.com/archives/2013/11/09/a-date-with-pivotitems/#comment-638479

Sub FilterPivot()

' Description: Wrapper function for my FilterPivot Function

' (Required in the event that a user wants to trigger the FilterPivot

' function and specify parameters at runtime, instead of programatiacally

' calling the routine)

' Programmer: Jeff Weir

' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

' Name/Version: Date: Ini: Modification:

' FilterPivot 20150305 JSW Initial programming

FilterPivot_Routine

End Sub

Sub FilterPivot_Inverse()

' Description: Wrapper function for my FilterPivot_Inverse Function

' (Required in the event that a user wants to trigger the FilterPivot_Inverse

' function and specify parameters at runtime, instead of programatiacally

' calling the routine)

' Programmer: Jeff Weir

' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

' Name/Version: Date: Ini: Modification:

' FilterPivot_Inverse 20150305 JSW Initial programming

FilterPivot_Routine bInverse:=True

End Sub

Function FilterPivot_AddRightClick()

' Description: Adds "Filter Pivotfield" shortcuts to PivotTable right-click menu

' Programmer: Jeff Weir

' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

' Name/Version: Date: Ini: Modification:

' AddShortcuts 20150305 JSW Initial programming

Dim cbr As CommandBar

Dim sMessage As String

FilterPivot_RemoveRightClick

Set cbr = Application.CommandBars("PivotTable Context Menu")

With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)

.Caption = "Filter Pivotfield"

.Tag = "FilterPivotField"

.OnAction = "FilterPivot"

.Style = msoButtonIconAndCaption

.Picture = Application.CommandBars.GetImageMso("FilterAdvancedByForm", 16, 16)

End With

With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)

.Caption = "Inversely Filter Pivotfield"

.Tag = "FilterPivotField"

.OnAction = "FilterPivot_Inverse"

.Style = msoButtonIconAndCaption

.Picture = Application.CommandBars.GetImageMso("FilterAdvancedMenu", 16, 16)

End With

End Function

Function FilterPivot_RemoveRightClick()

' Description: Removes "Filter Pivotfield" shortcuts from PivotTable right-click menu

' Programmer: Jeff Weir

' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

' Name/Version: Date: Ini: Modification:

' AddShortcuts 20150305 JSW Initial programming

Dim cbr As CommandBar

Dim sMessage As String

Dim ctrl As CommandBarControl

Set cbr = Application.CommandBars("PivotTable Context Menu")

For Each ctrl In cbr.Controls

If ctrl.Tag = "FilterPivotField" Then ctrl.Delete

End Function

Private Function FilterPivot_Slicers(ptTemp As PivotTable, pfTemp As PivotField, ptOriginal As PivotTable)

Dim sc As SlicerCache

' This sub-function contains code that requires Slicers

' It's in this stand-alone function, becaues it only gets called if user has Excel 2010 or later

' If it was incorporated DIRECTY within the FilterPivot function, that function wouldn't compile on pre 2010 machines

Set sc = ActiveWorkbook.SlicerCaches.Add(ptTemp, pfTemp)

sc.PivotTables.AddPivotTable ptOriginal

'Great, our original pivot now just has one item visible in the field of interest

'So we can delete the slicer connection

sc.Delete

End Function

Private Function FilterPivot_Routine(Optional rngPivotField As Range, Optional rngFilterItems As Range, Optional bInverse As Boolean = False) As Boolean

' weir.jeff@gmail.com

' You are free to use this code within your own applications, add-ins,

' documents etc but you are expressly forbidden from selling or

' otherwise distributing this source code without prior consent.

' This includes both posting free demo projects made from this

' code as well as reproducing the code in text or html format.

' ---------------------------------------------------------------------

' Date Initial Version Details

' 20131113 JSW 007 Initial Programming

' 20131203 JSW 008 Added Inverse Option

' 20140503 JSW 009 Changed so works in pre Excel 2010

' 20140503 JSW 010 Changed so pi.format check not performed in Excel 2013 +

' 20150223 JSW 011 Added check to ensure pfOriginal has .EnableMultiplePageItems set to TRUE if it is a pagefield.

' 20150429 JSW 012 Turned off events, cleared pfOriginal filter.

' 20150605 JSW 013 Fixed “Save source data with file” reset as per http://dailydoseofexcel.com/archives/2013/11/14/filtering-pivots-based-on-external-ranges/#comment-787682

'#############

'# Remarks #

'#############

' This code needs to be called by a wrapper function.

' e.g.

' Sub FilterPivot()

' FilterPivot_Routine

' End Sub

' Sub FilterPivot_Inverse()

' FilterPivot_Routine bInverse:=True

' End Sub

' If required, that wrapper function can also provide ranges

' specifying what PivotField to filter, and where the range of

' filter terms is. e.g.:

' FilterPivot_Routine Range("A2"), Range("C2:C20000")

' ...or

' FilterPivot_Routine ActiveCell, [tblFilterItems]

Dim ptOriginal As PivotTable

Dim ptTemp As PivotTable

Dim pfOriginal As PivotField

Dim pfTemp As PivotField

Dim pfFilterItems As PivotField

Dim lngFilterItems As Long

Dim pi As PivotItem

Dim ptFilterItems As PivotTable

Dim wksTemp As Worksheet

Dim wksPivot As Worksheet

Dim dic As Object

Dim varContinue As Variant

Dim strMessage As String

Dim varFormat As Variant

Dim bDateFormat As Boolean

Dim bDateWarning As Boolean

Dim bFirstItemVisible As Boolean

Dim varFirstItemVisible As Variant

Dim bEnableEvents As Boolean

Dim bScreenUpdating As Boolean

Dim lngCalculation As Long

Dim bSaveDataState As Boolean

FilterPivot_Routine = False 'Assume failure

On Error GoTo errhandler

Set wksPivot = ActiveSheet

'If neccessary, prompt user for the pivotfield of interest

If rngPivotField Is Nothing Then

On Error Resume Next

Set rngPivotField = ActiveCell

Set pfOriginal = rngPivotField.PivotField 'Tests if this is in fact a PivotField

If Err <> 0 Then

Err.Clear

Set rngPivotField = Nothing

Set rngPivotField = Application.InputBox( _

Title:="Where is the PivotField?", _

Prompt:="Please select a cell in the PivotField you want to filter", _

Type:=8)

On Error GoTo errhandler

If rngPivotField Is Nothing Then Err.Raise 996

End If

On Error GoTo errhandler

End If

Set pfOriginal = rngPivotField.PivotField

Set ptOriginal = pfOriginal.Parent

'Capture the SaveData state of the original pivot table

bSaveDataState = ptOriginal.SaveData

With pfOriginal

If .Orientation = xlPageField Then

If .EnableMultiplePageItems = False Then

.EnableMultiplePageItems = True

.ClearAllFilters

End If

End With

'If neccessary, prompt user for FilterItems table related to the pivotfield of interest

If rngFilterItems Is Nothing Then

On Error Resume Next

Set rngFilterItems = Application.InputBox( _

Title:="Where are the filter items?", _

Prompt:="Please select the range where your filter terms are.", _

Type:=8)

On Error GoTo errhandler

If rngFilterItems Is Nothing Then Err.Raise 996

End If

With Application

bScreenUpdating = .ScreenUpdating

bEnableEvents = .EnableEvents

lngCalculation = .Calculation

.ScreenUpdating = False

.EnableEvents = False

.Calculation = xlCalculationManual

End With

' Excel stores dates differently between PivotItems and Variant Arrays.

' For instance:

' ? CStr(varFilterItems(i, 1))

' 1/01/2013

' ? pi.Value

' 1/1/2013

' ? CStr(varFilterItems(i, 1)) = pi.Value

' False

'So we 'll turn our FilterItems into a PivotTable to ensure formats are treated the same.

Set wksTemp = Sheets.Add

rngFilterItems.Copy wksTemp.Range("A2")

wksTemp.Range("A1").Value = "FilterItems"

Set rngFilterItems = wksTemp.Range("A2").CurrentRegion

On Error GoTo errhandler

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _

rngFilterItems).CreatePivotTable _

TableDestination:=[C1], TableName:="appFilterItems"

Set ptFilterItems = wksTemp.PivotTables("appFilterItems")

Set pfFilterItems = ptFilterItems.PivotFields(1)

' Add FILTERItems to a Dictionary

Set dic = CreateObject("scripting.dictionary")

For Each pi In pfFilterItems.PivotItems

dic.Add pi.Value, 1 'The one does nothing

ptOriginal.ManualUpdate = True 'dramatically speeds up the routine, because the pivot won't recalculate until we're done

'Check if we're dealing with Excel 2010 or earlier and if PFOriginal is formatted as a date field.

' Basically there is a bug in Excel 2010 or earlier whereby if you try to do some things

' to a PivotItem containing a date but the PivotField number format is NOT a date format

' then you get an error.

' So we'll check the PivotField date format and see what it is

' Note that if a PivotField is based on a range that contains multiple formats

' then you get an error simply by checking what the PivotField number format is.

' So we'll instigate an On Error Resume Next to handle this

If Application.Version < 15 Then

On Error Resume Next

varFormat = pfOriginal.NumberFormat

On Error GoTo errhandler

If IsDate(Format(1, varFormat)) Then bDateFormat = True

End If

'Work out maximum amount of filteritems under bInverse scenario

If bInverse Then

lngFilterItems = pfOriginal.PivotItems.Count - rngFilterItems.Count

Else: lngFilterItems = rngFilterItems.Count

End If

If lngFilterItems / pfOriginal.PivotItems.Count < 0.5 And Application.Version >= 14 Then

'====================================================================================

' If it's likely that less than half of the source Pivot Field's

' items will be visible when we're done, then it will be quickest to hide all but one

' item and then unhide the PivotItems that match the filter terms

' Iterating through a large pivot setting all but one item to hidden is slow.

' And there's no way to directly do this except in Page Fields, and

' that method doesn't let you select multiple items anyway.

' Plus, as soon as you drag a page field with just one item showing to

' a row field, Excel clears the filter, so that all items are visible again.

' So we'll use a trick:

' * make the pf of interest in ptTemp a page field

' * turn off multiple items and select just one PivotItem

' * connect it to the original pivot with a slicer

' This will very quickly sync up the field on the original pivot so that only one field is showing.

' NOTE: WE CAN ONLY DO THIS IF USING EXCEL 2010 OR LATER using the below approach.

' If earlier version, we'll use the approach outlined in the ELSE part of this IF block.

' ALSO NOTE: If a PivotField has a non-Date format, but contains dates, then

' we can't programatically hide/show items. So we need to check for this.

'====================================================================================

'Identify a suitable item with which to filter the original PivotTable with

' As per note above,

' * If the PivotField format is NOT a date format,

' then we need to make sure that this first item is NOT a date.

' ...because otherwise we can't address it by VBA

' * If the PivotFied format IS a date format, then just use the first item.

' * We'll write that item to a range, then to a variant, so that Excel applies the

' same format to it as it does to items in our Filter list

If Not bDateFormat Then

For Each pi In pfOriginal.PivotItems

If IsDate(pi.Value) Then

If IsNumeric(pi.Value) Then

'We need the IsNumeric bit above because

'VBA thinks that some decimals encased in strings e.g. "1.1" are dates

'So we need to check whether this is a decimal and NOT a date

varFirstItemVisible = pi.Value

Exit For

Else:

If Not bDateWarning Then

Err.Raise Number:=997, Description:="Can't filter dates"

End If

Else:

varFirstItemVisible = pi.Value

Exit For

End If

Else:

varFirstItemVisible = pfOriginal.PivotItems(1).Value

End If

Set ptTemp = ptOriginal.PivotCache.CreatePivotTable(TableDestination:=wksTemp.Range("F1"))

Set pfTemp = ptTemp.PivotFields(pfOriginal.SourceName)

'Set the SaveData state the same as the original pivot table in case it is set to False

'When creating a new pivot table, by default it is set to True, which will carry over to the original pivot table

ptTemp.SaveData = bSaveDataState

With pfTemp

.Orientation = xlPageField

.ClearAllFilters

.EnableMultiplePageItems = False

.CurrentPage = pfTemp.PivotItems(varFirstItemVisible).Value

End With

Call FilterPivot_Slicers(ptTemp, pfTemp, ptOriginal)

' Check if FirstItemVisible should be visible or hidden when we are done

If dic.Exists(varFirstItemVisible) Then bFirstItemVisible = True

' Now try and add the PivotItems.

' If there's an error, we'll know that this item is also in the FilterTerms

On Error Resume Next

With dic

'The Not bInverse bit in the code blocks below effectively 'flip' the test "If Err.Number <> 0" to "If Err.Number = 0"

'in the case that bInverse argument is TRUE (meaning we want the Pivot to be filtered on things

' NOT in the list of search terms)

If Application.Version >= 15 Then

For Each pi In pfOriginal.PivotItems

dic.Add pi.Value, 1 'The 1 does nothing

If Err.Number <> 0 = Not bInverse Then

pi.Visible = True

End If

Err.Clear

Else: 'There's a bug in previous versions where you can't use .Visible for dates

'if the PivotField is set to General format.

For Each pi In pfOriginal.PivotItems

dic.Add pi.Value, 1 'The 1 does nothing

If Err.Number <> 0 = Not bInverse Then

' This item exists in our search term list, so we should unhide it

' Note that due to a bug in Excel 2010, if this item is a date

' but the PivotField format is NOT a date format, we can't

' programatically hide/show items, so we'll have to check this first

If Not bDateFormat Then

If Not IsNumeric(pi.Value) Then

'We need the Not IsNumeric bit above because VBA thinks that

' some decimals encased in strings e.g."1.1" are dates

If IsDate(pi.Value) Then

If Not bDateWarning Then

On Error GoTo errhandler

Err.Raise Number:=997, Description:="Can't filter dates"

On Error Resume Next

End If

Else: pi.Visible = True

End If

Else: pi.Visible = True

End If

Else: pi.Visible = True

End If

Err.Clear

End If 'If Application.Version >= 15 Then

End With

If Not bFirstItemVisible = Not bInverse Then

pfOriginal.PivotItems(varFirstItemVisible).Visible = False

If Err.Number <> 0 Then

MsgBox "None of the filter items were found in the Pivot"

pfOriginal.ClearAllFilters

Err.Clear

End If

Else:

' If it's likely that MORE than half of the source Pivot Field's items will be visible

' when we're done, then it's quickest to unhide all PivotItems and then hide the

' PivotItems that DON'T match the filter terms

pfOriginal.ClearAllFilters

' Now try and add the PivotItems.

' If there's an error, we'll know that this item is in the FilterItems

' Otherwise we'll hide it

On Error Resume Next

With dic

If Application.Version >= 15 Then 'Excel 2010 and earier have some 'issues' with dates

For Each pi In pfOriginal.PivotItems

dic.Add pi.Value, 1 'The 1 does nothing

If Err.Number = 0 = Not bInverse Then pi.Visible = False

Err.Clear

Else:

For Each pi In pfOriginal.PivotItems

dic.Add pi.Value, 1 'The 1 does nothing

If Err.Number = 0 = Not bInverse Then

'The Not bInverse bit effectively 'flips' the test "If Err.Number = 0" to "If Err.Number <> 0"

'in the case that bInverse argument is TRUE (meaning we want the Pivot to be filtered on things

' NOT in the list of search terms)

'This PivotItem NOT in FilterItems list. So hide it

'Note that IF this item is a date but the PivotField format is NOT a date format,

' then we can't programatically hide/show items, so we'll have to check this first

If Not bDateFormat Then

If Not IsNumeric(pi.Value) Then

'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates

If IsDate(pi.Value) Then

If Not bDateWarning Then

On Error GoTo errhandler

Err.Raise Number:=997, Description:="Can't filter dates"

On Error Resume Next

End If

Else: pi.Visible = False 'This item does not exist in the FilterItems. So hide it

End If

Else: pi.Visible = False 'This item does not exist in the FilterItems. So hide it

End If

Else: pi.Visible = False

End If

Err.Clear

End If 'If Application.Version >= 15 Then

End With

End If 'If lngFilterItems / pfOriginal.PivotItems.Count < 0.5 And Application.Version >= 14 Then

On Error GoTo errhandler

FilterPivot_Routine = True

errhandler:

If Err.Number <> 0 Then

Select Case Err.Number

Case Is = 0: 'No error - do nothing

Case Is = 996: 'Operation Cancelled

Case Is = 997: 'Can't filter dates

strMessage = "*** WARNING...I can't correctly filter dates in this Pivot ***"

strMessage = strMessage & vbNewLine & vbNewLine

strMessage = strMessage & "I've found at least one date in this PivotField. "

strMessage = strMessage & "Unfortunately due to a bug in Excel, if you have dates "

strMessage = strMessage & " in a PivotField AND that PivotField is NOT formatted "

strMessage = strMessage & " with a date format, then dates "

strMessage = strMessage & " can't be programatically filtered either in or out. "

strMessage = strMessage & vbNewLine & vbNewLine

strMessage = strMessage & " So you'll have to manually check to see whether "

strMessage = strMessage & " date items appear as they should."

strMessage = strMessage & vbNewLine & vbNewLine

strMessage = strMessage & "Do you want me to continue anyway? "

varContinue = MsgBox(Prompt:=strMessage, Buttons:=vbYesNo, Title:="Sorry, can't filter dates")

If varContinue = 6 Then

bDateWarning = True

Resume Next

Else: pfOriginal.ClearAllFilters

End If

Case Is = 998: 'Can't filter Datafields

MsgBox "Oops, you can't filter a DataField." & vbNewLine & vbNewLine & "Please select a RowField, ColumnField, or PageField and try again.", vbCritical, "Can't filter Datafields"

Case Is = 999: 'no pivotfield selected

MsgBox "Oops, you haven't selected a pivotfield." & vbNewLine & vbNewLine & "Please select a RowField, ColumnField, or PageField and try again.", vbCritical, "No PivotField selected"

Case Else:

MsgBox "Whoops, something went wrong"

End Select

End If

With Application

If Not wksTemp Is Nothing Then

.DisplayAlerts = False

wksTemp.Delete

.DisplayAlerts = True

End If

.ScreenUpdating = bScreenUpdating

.EnableEvents = bEnableEvents

.Calculation = lngCalculation

End With

If Not ptOriginal Is Nothing Then ptOriginal.ManualUpdate = False

End Function

A date with PivotItems

Posted on November 9, 2013March 17, 2018 by Jeff Weir

Howdy, folks. Jeff here again. I’ve been sharpening up some code to manually filter a PivotField based on an external list in a range outside the PivotTable. It works blazingly fast. Unless there’s dates as well as non-dates in my PivotField. In which case it errors out.

Try this:
Put “Pivot” in A1
Put =TODAY() in A2
Put =VALUE(TODAY()) in A3

Now make a PivotTable out of that data.

Now put this code into the VBE and step through it:

Sub WhatThe()

Dim pf As PivotField
Set pf = ActiveSheet.PivotTables(1).PivotFields(1)
With pf
    .NumberFormat = "d/mm/yyyy"
    .PivotItems(1).Visible = True
    .PivotItems(2).Visible = True
    .NumberFormat = "General"
    .PivotItems(1).Visible = True
    .PivotItems(2).Visible = True
End With
End Sub

Sub WhatThe()

Dim pf As PivotField

Set pf = ActiveSheet.PivotTables(1).PivotFields(1)

With pf

.NumberFormat = "d/mm/yyyy"

.PivotItems(1).Visible = True

.PivotItems(2).Visible = True

.NumberFormat = "General"

.PivotItems(1).Visible = True

.PivotItems(2).Visible = True

End With

End Sub

If the same thing happens to you as happens to me, you will either be speaking aloud the title of this routine, or you will be speaking aloud this:
Unable to get the PivotItems property of the PivotField class.

Go type these in the immediate pane:

? .PivotItems(1).name
41588
? .PivotItems(1).visible
True
? .PivotItems(2).name
10/11/2013
? .PivotItems(2).visible
Error 2042

? .PivotItems(1).name

41588

? .PivotItems(1).visible

True

? .PivotItems(2).name

10/11/2013

? .PivotItems(2).visible

Error 2042

What the…?

Now try these:

? ActiveSheet.PivotTables(1).PivotFields(1).numberformat
General
ActiveSheet.PivotTables(1).PivotFields(1).numberformat = "d/mm/yyyy"
? .PivotItems(2).name
10/11/2013
? .PivotItems(2).visible
True

? ActiveSheet.PivotTables(1).PivotFields(1).numberformat

General

ActiveSheet.PivotTables(1).PivotFields(1).numberformat = "d/mm/yyyy"

? .PivotItems(2).name

10/11/2013

? .PivotItems(2).visible

True

So it seems can’t do certain stuff to a PivotItem if that PivotItem is a date but your PivotField number format is set to General.

That’s weird.

Equally weird, try this:
Select the PivotTable, and record a macro as you change it’s number format back to General.

Sub WhatThe_Part2()   
 ActiveSheet.PivotTables("PivotTable14").PivotFields("Pivot").Name = "General"
End Sub

Sub WhatThe_Part2()

ActiveSheet.PivotTables("PivotTable14").PivotFields("Pivot").Name = "General"

End Sub

What the …? Change the PivotField Number Format, and you get a macro that tells you that you changed the PivotField name!

So what happens if you run that macro? Well, it changes the name of the PivotField:

It does nothing to the number format.

Strangely enough, I found some info on this problem at one of my most revisited blogposts that I had somehow missed: Jon Peltier’s Referencing Pivot Table Ranges in VBA

Stranger still, the answer was by Jon Peltier back in 2009 in relation to a question asked by….wait for it…me. Don’t know how I missed that. Must have been sleeping.
So I’ve come across this problem before, found an answer, completely forgotten about it, and then wasted 2 days trying to work out what the problem was, purely so I could Google my own answered question.

I’m going to read through all 238 ( and counting) comments in that thread and see what else Jon has told me over the years I’ve been learning VBA.
There’s also something on this at stackoverflow

Jeff

–edit–
Jon’s method was to loop through the pivot items, and compare the pivot item caption to what he was looking for:

For Each pi In pt.PivotFields("Order Month/Year").PivotItems
  If pi.Caption = Format(TheDate, "m/dd/yyyy") Then
  ' or If DateValue(pi.Caption) = TheDate Then
    '' FOUND IT
  End If
Next

For Each pi In pt.PivotFields("Order Month/Year").PivotItems

If pi.Caption = Format(TheDate, "m/dd/yyyy") Then

' or If DateValue(pi.Caption) = TheDate Then

'' FOUND IT

End If

But now I know it’s probably easier just to change the format of the PivotField.

—edit 30 May 2014 —
Prompted by Jerry Sullivan’s comment I found that this was only an issue for non-US regional settings, and that this issue is now fixed in Excel 2013. (Thank you, Microsoft. But why the heck didn’t you tell me you’d fixed it?)

According to IronyAaron in the comments at this thread:

When VBA recognizes the dates in the pivot cache, it reads the US version after parsing although the item is read as a locally formatted string. This therefore causes VBA to fail when recognizing Date variables.

Bummer! So write some code that filters PivotItems, and you might find that non-US users have issues, unless they change their regional settings in Windows to US beforehand. Good luck with that.

— edit over —

Excel isn’t fully cooked.

Posted on November 5, 2013November 5, 2013 by Jeff Weir

It’s still raw in the middle, a bit.

PivotTables are great, but why can’t I filter one based on an external range?
Shape Styles would be cool, if I could add my own styles.
Slicers are great, but why isn’t there an easy way to instantly get an overview of what Slicers are connected to what PivotTables, and at the same time use the same interface to effortlessly manage this and set up exclusions?
Charts are great, but why do I have to manually cut and paste them many times in order to make up the equivalent of a Small Multiple chart?

Fortunately, in most cases Excel is pretty programmable. If it doesn’t do something out of the box – or if using the built-in functionality is tedious – then given the requisite skills or the right Google search then you can almost always work around such bottlenecks fairly efficiently.

Unfortunately, Excel isn’t fully programmable no matter what skills you have. The Partial Text Search box that you can use to manually filter PivotFields on partial text pretty much instantly is awesome. But you can’t address it via VBA…it’s for humans only. Which means you’ve got to iterate through potentially large PivotItems collections s-l-o-w-l-y in maybe minutes in order to do something that users can do in seconds. (I won’t mention VBA support for PowerPivot as another example, because PowerPivot is still fairly new. Rough rule of thumb: Don’t complain about something until it’s been sitting around at least 5 years in an unfinished state. At least, that’s what I tell my wife).

I’ve got some great code to handle the Filtering Pivots and the Slicers things. And I can code up a cut and paste thing for Charts pretty easily. But that Partial Text Search box I can’t help you with. Maybe this will help get it on someone’s radar, but obviously including such ‘niceties’ in the in-box functionality isn’t trivial. Otherwise the dialog box for MSQuery (which I still use) would let me expand it. And the Name Manager would let me do the things that the better Name Manager will do. And so on.

So presumably these things are not trivial to enhance, or they would be enhanced already. But here’s the thing: by comparison, my code for filtering pivots or managing Slicers is trivial to roll out to users compared to the effort required to add this functionality natively.

So question: Why don’t MS supplement their great unfinished app by building and offering to users useful workarounds in one of the most agile-ready platforms there is…VBA? Why aren’t they monitoring forums and blogs for the best and brightest productivity enhancements, and buying the IP from content creators at a song, then offering it to users as add-ins that plug the gap until they get around to finishing Excel?

Regards,
Jeff Weir.
Cosmetic Surgeon.

Daily Dose of Excel

Haphazardly Posted Excel Information and Other Stuff

Author: Jeff Weir

Inversely filter a Pivot based on an external range

Much ado about ADO

UnPivot Shootout

snb’s approach

Multiple Consolidation Trick approach

And the winner is…

In an ideal world

UnPivot via SQL

Filtering Pivots based on external ranges.

Can we do better than that?

Enter the slicer

Slower Approach

A date with PivotItems

Excel isn’t fully cooked.