'
' This code enables the cascaded filtering of page items in a pivot table.
' The cascade is determined by the order of the page items on the worksheet
'
Option Explicit
Dim SavedFilterValues(100) As Variant
Dim SavedNFields As Integer
Dim SavedFilterRows(100) As Integer
Dim PageFields(100) As String
Dim ChangedPageField As Integer
Dim NPageFields As Integer
Dim lastcol As Integer
Dim FirstTime As Integer
'
' capture 1st entry to the worksheet with the pivot and save the values of filters
' Then we can tell which filters changed
' may make more sense to move to wokbook open - but would need to hardwire which sheet/pivot we are talking about'
'
Private Sub Worksheet_Activate()
Dim FieldList(100) As String
Dim FieldType(100) As Variant
Dim NFields As Integer
Dim p As PivotTable
Dim WhatChanged As Variant
Debug.Print ActiveSheet.Name
If (FirstTime = 0) Then
Debug.Print "1st time"
If (ActiveSheet.PivotTables.Count <> 1) Then
MsgBox ("More than 1 pivot on worksheet")
Else
Set p = ActiveSheet.PivotTables(1)
SavedNFields = BuildFieldTable(p, FieldList, FieldType, SavedFilterValues, WhatChanged)
End If
Else
Debug.Print "NOT 1st time"
End If
FirstTime = 1
End Sub
'
' Build table based on fields in pivot
'
' FieldList(): Names
' FieldTypes(): Orientation. eg whether Page or Row etc
' SavedFilterRows(): For Page Filters - row where found on sheet
' SavedFilterValues(): For Page Filters - last value of Page Filter (CurrentPage)
Private Function BuildFieldTable(Pivot As PivotTable, FieldList() As String, FieldType() As Variant, FilterValues() As Variant, WhatChanged As Variant) As Integer
Dim i, FieldIndex As Integer
Dim field As PivotField
Dim FieldOrientation As Variant
Dim NFields As Integer
NPageFields = 0
WhatChanged = ""
On Error GoTo 0
FieldIndex = 1
For i = 1 To Pivot.PivotFields.Count
Set field = Pivot.PivotFields(i)
FieldOrientation = field.Orientation
'Debug.Print "Field ", field.Name, " ", field.Orientation
Select Case FieldOrientation
Case xlHidden, xlDataField
Debug.Print "Skip ", FieldList(i)
Case xlColumnField, xlPageField, xlRowField
'Debug.Print "Field ", field.Name, " ", field.Orientation
Debug.Print field.Name, " ", field.DataRange.Address
FieldList(FieldIndex) = field.Name
FieldType(FieldIndex) = field.Orientation ' row, page etc
If (FieldOrientation = xlPageField) Then
NPageFields = NPageFields + 1
SavedFilterRows(FieldIndex) = field.DataRange.Row
lastcol = field.DataRange.Column
If (field.CurrentPage <> SavedFilterValues(FieldIndex)) Then
WhatChanged = field.Name
Debug.Print "Page Field ", WhatChanged, " changed. Value is now ", field.CurrentPage
End If
SavedFilterValues(FieldIndex) = field.CurrentPage
End If
FieldIndex = FieldIndex + 1
Case Else
Debug.Print "ERROR"
End Select
'Debug.Print "Filter Value is", field.Value
Next i
NFields = FieldIndex - 1
BuildFieldTable = NFields
If (WhatChanged = "") Then
If (NPageFields <> SavedNFields) Then
WhatChanged = "xNF"
Else
WhatChanged = "Refresh"
End If
End If
End Function
Private Function PageFieldOrder(WS As Worksheet, FieldType() As Variant, FieldList() As String, WhatChanged As Variant) As Integer
Dim StartRow, StartCol, i As Integer
Dim ChangedPageField As Integer
' work out page order precedence
' work out the order of the page fields
StartRow = 1
StartCol = lastcol + 1
WS.Cells(StartRow, StartCol).Value = "Field"
WS.Cells(StartRow, StartCol + 1).Value = "Row"
StartRow = StartRow + 1
For i = 1 To SavedNFields
If (FieldType(i) = xlPageField) Then
WS.Cells(StartRow, StartCol).Value = FieldList(i)
WS.Cells(StartRow, StartCol + 1).Value = SavedFilterRows(i)
StartRow = StartRow + 1
End If
Next i
Debug.Print ActiveSheet.Name, StartCol, StartRow
Debug.Print 1, StartCol, "<>", StartRow - 1, StartCol + 1
'Debug.Print WS.Name
'WS.Activate
Debug.Print WS.Range(WS.Cells(1, 3), WS.Cells(3, 4)).Address
WS.Range(WS.Cells(1, StartCol), WS.Cells(StartRow - 1, StartCol + 1)).Select
Selection.Sort Key1:="Row", Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ChangedPageField = -1
For i = 1 To NPageFields
PageFields(i) = WS.Cells(i + 1, lastcol + 1).Value
Debug.Print PageFields(i)
If (PageFields(i) = WhatChanged) Then ChangedPageField = i
Next i
PageFieldOrder = ChangedPageField
End Function
'
' Respond to pivot table update
' Possible causes:
' Filter Change
' Data Refresh
' Reformat
Private Sub Worksheet_PivotTableUpdate(ByVal OriginalPivot As PivotTable)
Dim OriginalWorkSheetName, TempWorkSheetName As String
Dim TempWorkSheet As Object
Dim FieldIndex
Dim FieldList(100) As String
Dim fieldname As String
Dim WhatChanged As Variant
Dim FieldType(100) As Variant
Dim field As PivotField
Dim TmpPivot As PivotTable
Dim FieldOrientation As Variant
Dim Thisfield As PivotField
Dim i, Nrows As Integer
Dim KeepRowName As String
Dim ErrorFlag As Integer
Dim WhichField As Integer
Dim j As Integer
Dim PF As String
Dim ChangedPf As PivotField
Dim item As PivotItem
Dim temp As Variant
Dim ScratchWorkSheet As Object
Dim StartRippleFieldName As String
Dim StartRipple As Integer
Dim ExcelVersion As String
Dim SUoff As Boolean
SUoff = False
SUoff = True
ErrorFlag = 1
On Error GoTo clearup
Application.EnableEvents = False
Application.DisplayAlerts = False
If (SUoff) Then Application.ScreenUpdating = False
OriginalWorkSheetName = ActiveSheet.Name
Debug.Print OriginalPivot.Name
If (ActiveSheet.PivotTables.Count <> 1) Then
Debug.Print "More than 1 pivot on worksheet. No processing"
GoTo clearup ' sorry about the goto, but need to clearup before exit
End If
SavedNFields = BuildFieldTable(OriginalPivot, FieldList, FieldType, SavedFilterValues, WhatChanged)
Select Case OriginalPivot.Version
Case 1, 2 ' xlPivotTableVersion11
ExcelVersion = "2003"
Case 3 'xlPivotTableVersion12
ExcelVersion = "2007"
Case 4 ' xlPivotTableVersion14
ExcelVersion = "2010"
Case Else
ExcelVersion = "Unknown"
End Select
If (NPageFields < 2) Then
Debug.Print "Cascaded filter needs more than 1 page to be activated"
GoTo clearup
End If
Set ScratchWorkSheet = Sheets.Add
ChangedPageField = PageFieldOrder(ScratchWorkSheet, FieldType, FieldList, WhatChanged)
' without these 2 lines you get stale pivot items and error 1004
OriginalPivot.PivotCache.MissingItemsLimit = xlMissingItemsNone
OriginalPivot.PivotCache.Refresh
If (ChangedPageField <> -1) Then
' enable all if set to "All"
Set ChangedPf = OriginalPivot.PivotFields(PageFields(ChangedPageField))
Debug.Print ChangedPf.CurrentPage
If (StrComp(ChangedPf.CurrentPage, "(All)") = 0) Then
For Each item In ChangedPf.PivotItems
Debug.Print "All clearing item", item.Value
item.Visible = True
Next item
End If
End If
StartRipple = 1
If (ChangedPageField <> -1) Then
StartRipple = ChangedPageField + 1
If ((StrComp(ChangedPf.CurrentPage, "(All)") = 0) And ChangedPageField <> 1) Then
StartRipple = ChangedPageField
End If
End If
StartRippleFieldName = PageFields(StartRipple)
' identify unique values of each page field using a copy pivot
If (StartRipple <= NPageFields) Then
Sheets(OriginalWorkSheetName).Copy after:=ActiveSheet
TempWorkSheetName = ActiveSheet.Name
Set TempWorkSheet = ActiveSheet
Set TmpPivot = TempWorkSheet.PivotTables(1)
' always need a row field. start with 1st to filter on
TmpPivot.PivotFields(StartRippleFieldName).Orientation = xlRowField
KeepRowName = StartRippleFieldName
' prepare the copy. move all fields except one row field to be page
For i = 1 To SavedNFields
fieldname = FieldList(i)
If (fieldname <> StartRippleFieldName) Then
Select Case FieldType(i)
Case xlHidden, xlDataField
Debug.Print "Should not happen ", FieldList(i)
Case xlPageField
'TmpPivot.PivotFields(fieldname).Orientation = xlPageField
Debug.Print ""
Case xlColumnField ' remove it
TmpPivot.PivotFields(fieldname).Orientation = xlHidden
Case xlRowField ' remove it
TmpPivot.PivotFields(fieldname).Orientation = xlHidden
End Select
End If
Next i
' clear the filters further down the ripple
' for this you have to make all the fields visible
If (NPageFields > StartRipple) Then
For i = StartRipple + 1 To NPageFields
Set Thisfield = TmpPivot.PivotFields(PageFields(i))
For Each item In Thisfield.PivotItems
Debug.Print item.Name, " vis was ", item.Visible
item.Visible = True
Next item
' TmpPivot.PivotFields(PageFields(i)).PivotItems("(All)").Visible = True
TmpPivot.PivotFields(PageFields(i)).CurrentPage = "(All)"
Debug.Print Err.Number
Next i
End If
' create a blank row 1
TempWorkSheet.Rows("1:1").Select
Selection.Insert Shift:=xlDown
If (NPageFields > ChangedPageField) Then
For i = StartRipple To NPageFields
'temp = PageFields(i)
Call SetFilter(PageFields(i), OriginalPivot, TmpPivot, FieldList, SavedNFields, KeepRowName)
Next i
End If
End If
ErrorFlag = 0
clearup:
Debug.Assert ErrorFlag = 0
If (Not Err Is Nothing) Then Debug.Print "error is ", Err.Number
'TmpPivot.ManualUpdate = False
If (TempWorkSheetName <> "") Then Sheets(TempWorkSheetName).Delete
ScratchWorkSheet.Delete
Sheets(OriginalWorkSheetName).Activate
On Error GoTo 0
' probabbly no need for this attempt to ensure currentpage is set
' problem was that you cannot set "(all)" unless all items visible
For i = 1 To NPageFields
WhichField = -1
PF = PageFields(i)
For j = 1 To SavedNFields
If (PF = FieldList(j)) Then WhichField = j
Next j
If WhichField >= 0 Then
temp = OriginalPivot.PivotFields(FieldList(WhichField)).CurrentPage
OriginalPivot.PivotFields(FieldList(WhichField)).CurrentPage = SavedFilterValues(WhichField)
Set Thisfield = OriginalPivot.PivotFields(FieldList(WhichField))
Else
Debug.Print "Error"
End If
Next i
'OriginalPivot.RefreshTable
If (SUoff) Then Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
For i = 1 To NPageFields
WhichField = -1
PF = PageFields(i)
For j = 1 To SavedNFields
If (PF = FieldList(j)) Then WhichField = j
Next j
If WhichField >= 0 Then
'OriginalPivot.PivotFields(FieldList(WhichField)).CurrentPage = SavedFilterValues(WhichField)
Set Thisfield = OriginalPivot.PivotFields(FieldList(WhichField))
Else
Debug.Print "Error"
End If
Next i
On Error GoTo 0
End Sub
' make the temp pivot have fieldname as the sole row field and extract possible values
Private Sub SetFilter(FieldToCustomise As String, ByVal OriginalPivot As PivotTable, TmpPivot As PivotTable, FieldList() As String, NFields As Integer, KeepRowName As String)
Dim PossibleValues As Variant
Dim PossibleValueRange As Range
Dim PossibleValueRange2 As Range
Dim FindResult As Range
Dim item As PivotItem
Dim i As Integer
Dim ErrorFlag As Integer
Dim PivotFieldObject As PivotField
Dim NPossibleCells As Integer
Dim ItemValue As String
On Error GoTo clearup2
ErrorFlag = 1
Debug.Print "Customising field", FieldToCustomise, " Current Page is ", OriginalPivot.PageFields(FieldToCustomise).CurrentPage
' make FieldToCustomise the only row field
If (FieldToCustomise <> KeepRowName) Then
TmpPivot.PivotFields(FieldToCustomise).Orientation = xlRowField
TmpPivot.PivotFields(KeepRowName).Orientation = xlPageField
End If
'TmpPivot.PivotFields(FieldToCustomise).AutoSortOrder = xlManual
TmpPivot.ManualUpdate = True
On Error Resume Next ' skip errors here
For Each item In TmpPivot.PivotFields(FieldToCustomise).PivotItems
ItemValue = item.Value
'Debug.Print "Clearing", ItemValue
item.Visible = True
Next item
TmpPivot.ManualUpdate = False
On Error GoTo clearup2
' now have set of possible values - store in PossibleValues
Set PossibleValueRange = TmpPivot.RowRange
NPossibleCells = TmpPivot.RowRange.Count
Set PossibleValueRange2 = Application.Range(PossibleValueRange.Cells(2, 1), PossibleValueRange.Cells(NPossibleCells - 1))
PossibleValueRange2.Select
Selection.Copy
ActiveSheet.Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Set PivotFieldObject = OriginalPivot.PivotFields(FieldToCustomise)
OriginalPivot.ManualUpdate = True
' now set the list of values to display in the filter drop down (in original pivot)
For Each item In OriginalPivot.PivotFields(FieldToCustomise).PivotItems
ItemValue = item.Value
'Debug.Print "PivotFilter item ", itemvalue
'On Error Resume Next
Set FindResult = PossibleValueRange2.Find(ItemValue)
'On Error GoTo Clearup
If (FindResult Is Nothing) Then
Debug.Print "Setting ", ItemValue, " invisible"
If ((ItemValue <> "(blank)") And (ItemValue <> "#N/A") And (Not Len(ItemValue) = 0)) Then item.Visible = False ' avoid runtime error for item (blank)
Else
item.Visible = True
Debug.Print ItemValue, " set visible"
End If
Next item
If (FieldToCustomise <> KeepRowName) Then
TmpPivot.PivotFields(KeepRowName).Orientation = xlRowField
TmpPivot.PivotFields(FieldToCustomise).Orientation = xlPageField
End If
OriginalPivot.ManualUpdate = False
ErrorFlag = 0
clearup2:
Debug.Print "Finsihed Customising field", FieldToCustomise, " Current Page is ", OriginalPivot.PageFields(FieldToCustomise).CurrentPage
Debug.Print "Last value was <", ItemValue, ">"
Debug.Assert ErrorFlag = 0
Debug.Print Len(ItemValue)
Debug.Print Err.Number
On Error GoTo 0
End Sub
ffice
