Home > Pivot > Filters > Source Data Macro to Filter Pivot Table DataUse 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. |
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 .
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
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.
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
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:
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
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.
Last updated: January 26, 2023 3:51 PM