Overwrite double click action in a PivotTable to go to filtered source data

Question

I'm trying to create a PivotTable in which a double click on a value leads the user to the filtered source sheet with the rows that this value represents, rather than a new sheet with the underlying data.

This is how far I've gotten, but I'm having issues extracting the relevant row and column names / values, as well as the filters currently active in the pivottable.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim rng As Range
    Dim wks As Worksheet
    Dim pt As PivotTable

    ' Based on http://stackoverflow.com/questions/12526638/how-can-you-control-what-happens-when-you-double-click-a-pivot-table-entry-in-ex
    Set wks = Target.Worksheet
    For Each pt In wks.PivotTables()
        Set rng = Range(pt.TableRange1.Address)
        If Not Intersect(Target, rng) Is Nothing Then
            Cancel = True
        End If
    Next  

     ' Source: http://www.mrexcel.com/forum/excel-questions/778468-modify-pivottable-double-click-behavior.html
     On Error GoTo ExitNow
     With Target.PivotCell
         If .PivotCellType = xlPivotCellValue And _
             .PivotTable.PivotCache.SourceType = xlDatabase Then
                 SourceTable = .PivotTable.SourceData
                 MsgBox SourceTable
                 ' I found the sourcetable, how would I collect the row/column
                 ' names and values in order to filter this table?
         End If
     End With

ExitNow: Exit Sub
End Sub

In order to filter the source sheet, I need to extract the following characteristics upon a double click:

• The filters active in the current PivotTable (the original** 'Fieldname' and the relevant filters)
• The original** headers and row names and values relevant to the aggregate being selected (e.g. FieldX = 2013, FieldY="X"), that will enable me to filter the source sheet and present the underlying rows.

** Note that I'm not sure if this is relevant, but I extensively stumble upon PivotTables in which the row names shown are not the same as those in the source datasheet (by manually renaming them in the PivotTable). Also, is it possible to extract the 'groupings' created in the PivotTables?

Using these characteristics, the VBA for locating the source data and applying the relevant filters should be relatively straightforward. In most cases, the source table is an 'Excel Table', if this is relevant.

Any help is greatly appreciated.

Answer 1

The solution to this depends greatly on the filters you have in place. The way that PivotFilters are defined is different from the way that AutoFilters are defined. This means that you will need to do a translation for each type of filter that is in place.

AutoFilters do all of their magic in the Criteria1 whereas the PivotFilters have a FilterType and Value1 to make it work. This is the translation step.

For simple equality, it is fairly easy and that is the code included below. It address the issue of how to find the column header and set the filter.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim pt As PivotTable

    Dim wks As Worksheet
    Set wks = Target.Worksheet
    For Each pt In wks.PivotTables()
        If Not Intersect(Target, pt.TableRange1) Is Nothing Then
            Cancel = True
        End If
    Next

    If Cancel <> True Then
        Exit Sub
    End If

    Set pt = Target.PivotCell.PivotTable

    Dim rng As Range
    Set rng = Application.Range(Application.ConvertFormula(pt.SourceData, xlR1C1, xlA1))

    Dim sht_rng As Worksheet
    Set sht_rng = rng.Parent
    sht_rng.AutoFilterMode = False

    Dim pf As PivotField
    For Each pf In pt.PivotFields
        Dim pfil As PivotFilter
        For Each pfil In pf.PivotFilters
            If pfil.FilterType = xlCaptionEquals Then
                rng.AutoFilter Field:=Application.Match(pf.SourceName, rng.Rows(1), 0), Criteria1:=pfil.Value1
            End If
        Next pfil
    Next pf

    sht_rng.Activate
    rng.Cells(1, 1).Select
End Sub

Couple of notes:

• I am using PivotTable.SourceData to get the range of cells that are involved. This returns a value in R1C1 notation, so I convert it to A1 notation using Application.ConvertFormula. I then need to use Application.Range to look up this string. (Since this code is executing within the scope of a specific Worksheet you need to add Application here so it expands the scope of the search)
• After that it is a simple matter of iterating through all the PivotFields and their PivotFilters.
• Inside that loop, then you need to find the column header (using Application.Match in the header row: .Rows(1)) and add the filter. This is where the conversion steps are required. You could do a Select... Case for each supported type of filter.
• You might also want to check out CurrentPage if any of the fields is a filter instead of a row/column.
• Finally, it is possible for there to be manual filters instead of the label filters which I am iterating through. You can loop through PivotItems and check for Visible if you want those.

Hopefully this code gets you started but also hints at the complexity of the task involved. You will likely want to limit yourself to supporting specific types of filters.

Pictures of Pivot and data

pivot table with filters

all data

filtered data

Answer 2

Using the snippets brought forward by Byron's answer, I came up with the following. It doesn't work with grouped columns, nor does it work with tables. For now, at least I can work with regular ranges and PivotTables with tidy source data.

I use the following code to call a second procedure, note that (by far) I'm not an expert in VBA; I just wanted this functionality in a spreadsheet I'm working on:

Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    Dim pt As PivotTable
    Dim wks As Worksheet
    Set wks = target.Worksheet

    ' Find out if we selected a pivottable, cancel default behaviour
    For Each pt In wks.PivotTables()
        If Not Intersect(target, pt.TableRange1) Is Nothing Then
            Cancel = True
        End If
    Next

    If Cancel <> True Then
        Exit Sub
    End If

    Call pivot_filter_source(target)
    Application.ScreenUpdating = True
End Sub

And the procedures that are called:

Public Sub pivot_filter_source(target As Range)
    'Dim target As Range
    'Set target = Sheets("Pivot").Range("E11")
    Dim pt As PivotTable
    Dim wks As Worksheet
    Set wks = target.Worksheet

    ' Derive PivotTable
    Set pt = target.PivotCell.PivotTable

    Dim rng As Range

    ' Define the source data
    Set rng = Application.Range(Application.ConvertFormula(pt.SourceData, xlR1C1, xlA1))
    ' TODO: Make it work with Excel Tables

    Dim pf As PivotField
    Dim pi As PivotItem
    Dim page_filters As Collection
    Set page_filters = New Collection
    Dim list As Variant

    ' Loop over page filters and add their values to array
    For Each pf In pt.PageFields
        Debug.Print "Filter field: " & pf.SourceName

        For Each pi In pf.PivotItems
            ' Find out if filter contains filtered items
            If pi.Visible Then
                Debug.Print "... filter: " & pi.Value
                If Contains(page_filters, pf.SourceName) Then
                    list = page_filters.Item(pf.Name)
                    ReDim Preserve list(UBound(list) + 1)
                    filter_value = pi.Value
                    If pi.Value = "(blank)" Then
                        filter_value = "="
                    End If

                    list(UBound(list)) = filter_value
                    page_filters.Remove (pf.SourceName)
                    page_filters.Add list, pf.SourceName
                Else
                    list = Array(pf.SourceName, pi.Value)
                    page_filters.Add list, pf.SourceName
                    Set list = Nothing
                End If
            End If
        Next pi
    Next pf

    Set rng = Application.Range(Application.ConvertFormula(pt.SourceData, xlR1C1, xlA1))
    rng.Parent.Activate

    On Error Resume Next
    ActiveSheet.ShowAllData

    ' Loop over the extracted filters, apply
    Dim source_column_name As String
    Dim fieldname As String
    Dim filter_values As Variant

    For Each source_column In page_filters
        ' Handle '(blank)' values
        For i = 0 To UBound(source_column) - 1
            If source_column(i) = "(blank)" Then source_column(i) = "="
        Next
        fieldname = source_column(0)
        filter_values = source_column
        Call filter_range(rng, fieldname, filter_values)
    Next

    ' Loop over columns of interest
    For Each pi In target.PivotCell.ColumnItems
        Debug.Print pi.Parent.SourceName & " ==> " & pi.SourceName
        filter_values = Array(pi.SourceName)

        If pi.SourceName = "(blank)" Then filter_values = Array("=")
        Call filter_range(rng, pi.Parent.SourceName, filter_values)
    Next

    ' Loop over rows of interest
    For Each pi In target.PivotCell.RowItems
        Debug.Print pi.Parent.SourceName & " ==> " & pi.SourceName
        filter_values = Array(pi.SourceName)
        If pi.SourceName = "(blank)" Then
            filter_values = Array("=")
        End If
        Call filter_range(rng, pi.Parent.SourceName, filter_values)
    Next

    rng.Parent.Activate

End Sub



Public Sub filter_range(rng As Range, field_name As String, filter_values As Variant)
    rng.AutoFilter _
            Field:=Application.Match(field_name, rng.Rows(1), 0), _
            Criteria1:=filter_values, _
            Operator:=xlFilterValues

End Sub



Public Function Contains(col As Collection, key As Variant) As Boolean
    Dim obj As Variant
    On Error GoTo err
        Contains = True
        obj = col(key)
        Exit Function
err:
        Contains = False
End Function

Answer 3

Thanks a lot for this thread. I don't know why Microsoft has never provided this feature natively. When you check your data in Pivots you often want to clean the source data directly. Your idea is to apply the pivot structure and filters individually on the source data, however you can also apply the following simple trick: To filter the source list I have been using the advanced filter. After a double click in a pivot a new sheet gets created. This contains a result list that becomes my filter criteria for the advanced filter on the source data. Since the advanced filter allows multiple ANDs (by column) and ORs (by row) conditions your source list should always be filtered properly. I usually Limit the filter range to the first column where my unique record ID from the source table is displayed, this way my filtered list is always a hundred procent correct. One disadvantage of advanced filters is that it removes the autofilter in the Header of your source list. That is why your above solution is smarter ;-)