Private Function Slice(Which As Range, Where As Range) As Range
' written by Héctor Miguel Orozco Díaz
' http://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, Zone As Byte, nXT As Integer, nXT2 As Integer
Dim pgFlds As Integer, colFlds As Integer, 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, 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
