|
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.
|
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
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.
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:
- Right-click on the pivot table worksheet tab
- Click on View Code
- Paste the code where the cursor is flashing.
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
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 Show Details
Last updated: January 26, 2023 3:51 PM