Contextures

Home > Pivot > Filters > Source Data

Macro to Filter Pivot Table Data

Use this macro to filter the pivot table source data when you double-click a value cell. Prevents Excel from adding Show Details sheets, and makes it easy to update specific records, if necessary. Thanks to Héctor Miguel Orozco Díaz, who developed this macro.

double-click pivot table cell

Pivot Table Data Filter Macro

When you double-click a data cell in an Excel pivot table, a new worksheet is created, with the related records from the source data. That is a Pivot Table's Show Details command, and if you use it too often, your workbook can fill up with extra sheets.

Instead of creating new sheets, this Pivot Table Data Filter Macro gives you another option. This macro applies a filter to the source data, based on the pivot items connected to the double-clicked cell.

NOTE: The macro works for Excel pivot tables that are based on a worksheet list in the same workbook .

See an Example

In the screen shot shown below, I double-clicked the value cell that is circled. That cell shows the total Cost, for Class_A, in Month_3, for Store_1 and Code_A

double-click pivot table cell

The Pivot Table Data Filter Macro runs automatically when a pivot table value is clicked.

On the worksheet with the source data, the records are filtered for Class_A, Month_3, Store_1, Code_A. You could update any of those records, if necessary. Then go back to the pivot table, and refresh it, to see the updated results.

filtered source data

Add the Source Data Filter Code

The following code filters the Excel pivot table source data if a data cell in the pivot table was double clicked.

Copy this code, and paste it into a regular code module. Or, download the sample workbook, and copy the code from there.

Private Function Slice(Which As Range, Where As Range) As Range
' written by Héctor Miguel Orozco Díaz
' https://www.contextures.com/xlPivot-Filter-Source-Data.html
' === general function for "divorcing" ranges (the opposite of Union) ===
  Dim xCell As Range
  For Each xCell In Where
    If Intersect(xCell, Which) Is Nothing Then
      Set Slice = Union(IIf(Slice Is Nothing, xCell, Slice), xCell)
    End If
  Next
End Function

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

Sub PTCellFilterExcelDataSource()
' written by Héctor Miguel Orozco Díaz
' === and the procedure (modified due to 2007 language issue) ===
  Application.ScreenUpdating = False
  With ActiveSheet
    If .PivotTables.Count = 0 Then
      Exit Sub
    End If
    Dim pt As Byte, Go4It As Boolean, rowL As String
    For pt = 1 To .PivotTables.Count
      If Not Intersect(ActiveCell, .PivotTables(pt) _
              .DataBodyRange) Is Nothing Then
        Go4It = True
        Exit For
      End If
    Next
    If Not Go4It Then
      Exit Sub
    End If
    rowL = Application.International(xlUpperCaseRowLetter)
    Dim srcData As String, xSht As String, xRng As String
    Dim srcTitles As String, cpFilter As String
    Dim Partial As Byte, Totals As Byte
    Dim Zone As Byte, nXT As Integer, nXT2 As Integer
    Dim pgFlds As Integer, colFlds As Integer
    Dim lblFlds As Integer, rowFlds As Integer
    Dim dataFlds As Integer, nRows As Integer, nCols As Integer
    Dim pTFld As PivotField, dataCols As Range, colsP As Range
    Dim rowsF As Range, rowsD As Range, xCell As Range, cellsD As Range
    Dim cellsPC As Range, cellsPR As Range, cellsPX As Range
    Dim cellsTC As Range, cellsTR As Range
    Dim cellsTCX As Range, cellsTRX As Range
    With .PivotTables(pt)
      srcData = .PivotCache.SourceData
      xSht = IIf(InStr(srcData, "!") > 0, Application.Substitute(Left(srcData, _
        InStr(srcData, "!") - 1), "'", ""), .Parent.Name)
      With Application
        xRng = .ConvertFormula(.Substitute(Mid(srcData, _
          InStr(srcData, "!") + 1), rowL, "R"), xlR1C1, xlA1)
      End With
      srcTitles = Range(xRng).Resize(1).Address
      pgFlds = .PageFields.Count
      colFlds = .ColumnFields.Count
      lblFlds = .DataLabelRange.Columns.Count
      rowFlds = .RowFields.Count - lblFlds
      dataFlds = .DataFields.Count
      If rowFlds > 1 Then
        Partial = 1
      End If
      If colFlds > 1 Then
        Partial = Partial + 2
      End If
      If .RowGrand Then
        Totals = 1
      End If
      If .ColumnGrand Then
        Totals = Totals + 2
      End If
      With .ColumnRange
        For Each xCell In .Offset(.Rows.Count - 1) _
             .Resize(1, .Columns.Count + (Totals > 1))
          If Application.CountIf(Worksheets(xSht).Range(xRng), xCell) > 0 Then
            Set dataCols = Union(IIf(dataCols Is Nothing, xCell, dataCols), xCell)
          Else
            Set colsP = Union(IIf(colsP Is Nothing, xCell, colsP), xCell)
          End If
        Next
      End With
      For Each pTFld In .DataFields
        Set rowsD = Union(pTFld.DataRange.EntireRow, _
            IIf(rowsD Is Nothing, pTFld.DataRange.EntireRow, rowsD))
      Next
      With .RowRange
        Set rowsF = Intersect(rowsD, .Resize(, .Columns.Count - lblFlds))
      End With
      Set cellsD = Intersect(rowsD, dataCols.EntireColumn)
      If Partial > 1 Then
        Set cellsPC = Intersect(rowsD, colsP.EntireColumn)
      End If
      With .DataBodyRange.Resize(.DataBodyRange.Rows.Count  _
             + ((Totals \ 2 = 1) * dataFlds))
        If Partial \ 2 = 1 Then
          Set cellsPR = Slice(cellsD, Intersect(.EntireRow, dataCols.EntireColumn))
        End If
        If Partial = 3 Then
          Set cellsPX = Slice(cellsPC, Intersect(.EntireRow, colsP.EntireColumn))
        End If
      End With
      If Totals > 1 Then
        Set cellsTC = Intersect(rowsD, .ColumnRange.Offset _
          (.ColumnRange.Rows.Count - 1, _
            .ColumnRange.Columns.Count - 1).Resize(1, 1).EntireColumn)
      End If
      If Totals \ 2 = 1 Then
        Set cellsTR = Intersect(.DataBodyRange.Offset _
          (.DataBodyRange.Rows.Count - dataFlds).Resize(dataFlds), _
             dataCols.EntireColumn)
      End If
      If Totals = 3 Then
        If Not cellsPR Is Nothing Then
          Set cellsTCX = Intersect(cellsPR.EntireRow, cellsTC.EntireColumn)
        End If
      End If
      If Totals = 3 Then
        If Not cellsPC Is Nothing Then
          Set cellsTRX = Intersect(cellsTR.EntireRow, cellsPC.EntireColumn)
        End If
      End If
      If Not Intersect(ActiveCell, cellsD) Is Nothing Then
        Zone = 1
      End If
      If Not cellsPC Is Nothing Then
        If Not Intersect(ActiveCell, cellsPC) Is Nothing Then
          Zone = 2
        End If
      End If
      If Not cellsPR Is Nothing Then
        If Not Intersect(ActiveCell, cellsPR) Is Nothing Then
          Zone = 3
        End If
      End If
      If Not cellsPX Is Nothing Then
        If Not Intersect(ActiveCell, cellsPX) Is Nothing Then
          Zone = 4
        End If
      End If
      If Not cellsTC Is Nothing Then
        If Not Intersect(ActiveCell, cellsTC) Is Nothing Then
          Zone = 5
        End If
      End If
      If Not cellsTR Is Nothing Then
        If Not Intersect(ActiveCell, cellsTR) Is Nothing Then
          Zone = 6
        End If
      End If
      If Not cellsTCX Is Nothing Then
        If Not Intersect(ActiveCell, cellsTCX) Is Nothing Then
          Zone = 7
        End If
      End If
      If Not cellsTRX Is Nothing Then
        If Not Intersect(ActiveCell, cellsTRX) Is Nothing Then
          Zone = 8
        End If
      End If
      If Not cellsTR Is Nothing And Not cellsTC Is Nothing Then
        If Not Intersect(ActiveCell, cellsTR.EntireRow,  _
             cellsTC.EntireColumn) Is Nothing Then
          MsgBox "ActiveCell is @ the Bottom-Right End of Pivot Table !!!"
          GoTo Done ' Zone = 9 '
        End If
      End If
      If Worksheets(xSht).AutoFilterMode Then
        Worksheets(xSht).AutoFilterMode = False
      End If
      If pgFlds = 0 Then
        GoTo NoPages
      End If
      For nXT = 1 To pgFlds
        With .PageFields(nXT)
          cpFilter = .CurrentPage
          If Val(Application.Version) < 12 Then
            GoTo SkipLoop
          Else
            cpFilter = "(All)"
          End If
          For nXT2 = 1 To .PivotItems.Count
            If .CurrentPage = .PivotItems(nXT2) Then
              cpFilter = .PivotItems(nXT2)
              Exit For
            End If
          Next
SkipLoop:
          If cpFilter <> "(All)" Then
            Worksheets(xSht).Range(xRng).AutoFilter Field:= _
             Application.Match(.Name, Worksheets(xSht).Range(srcTitles), 0), _
             Criteria1:=CStr(cpFilter)
          End If
        End With
      Next
NoPages:
      Select Case Zone:
        Case 1, 2, 5
          nRows = rowFlds
      End Select
      Select Case Zone
        Case 1, 3, 6
          nCols = colFlds
      End Select
      Select Case Zone
        Case 3, 4, 7
          nRows = rowFlds - 1
      End Select
      Select Case Zone
        Case 2, 4, 8
          nCols = colFlds - 1
      End Select
      For nXT = 1 To nRows
        With Cells(ActiveCell.Row, .RowRange.Cells(1).Column).Offset(, -1 + nXT)
          Worksheets(xSht).Range(xRng).AutoFilter Field:= _
            Application.Match(.PivotField.Name,  _
             Worksheets(xSht).Range(srcTitles), 0), _
            Criteria1:=.PivotItem.Name
        End With
      Next
      For nXT = 1 To nCols
        With Cells(.ColumnRange.Cells(1).Row, ActiveCell.Column).Offset(nXT)
          Worksheets(xSht).Range(xRng).AutoFilter Field:= _
            Application.Match(.PivotField.Name,  _
             Worksheets(xSht).Range(srcTitles), 0), _
            Criteria1:=.PivotItem.Name
        End With
      Next
    End With
  End With
Done:
  Set cellsTRX = Nothing
  Set cellsTCX = Nothing
  Set cellsTR = Nothing
  Set cellsTC = Nothing
  Set cellsPX = Nothing
  Set cellsPR = Nothing
  Set cellsPC = Nothing
  Set cellsD = Nothing
  Set rowsD = Nothing
  Set rowsF = Nothing
  Set colsP = Nothing
  Set dataCols = Nothing

End Sub 

Note: In Excel 2007 there are some issues if (All) is the current selection in a Report Filter, so the code addresses that situation

Add the Event Code

The following code is stored in the worksheet module for the Excel pivot table worksheet. This is an event procedure that runs automatically when a cell on the worksheet is double-clicked.

To add the code:

  1. Right-click on the pivot table worksheet tab
  2. Click on View Code
  3. Paste the code where the cursor is flashing.go to top
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' written by Héctor Miguel Orozco Díaz
  If Target.PivotTable = PivotTables(1) Then
    Cancel = True
    PTCellFilterExcelDataSource
  End If

End Sub 

go to top

Get the Sample File

There are two versions of the code, so download either file, or both. The zipped files are in xlsm format, and contain macros.

1. Get the zipped Filter Excel Pivot Table Source Data sample file with original code shown above

2. For a shorter version of the code, get the zipped Filter Excel Pivot Table Source Data sample file - Short.

More Pivot Table Tutorials

Pivot Table Source Data

Fix Pivot Table Source Data

Show Details (DrillDown)

Pivot Data Source Macros

Pivot Table Introduction

FAQs - Pivot Tables

Pivot Table Show Details

 

About Debra

 

Last updated: January 26, 2023 3:51 PM