Sub PivotRefresh()
'--filters PivotTables to show only dates between start and
' end dates (inclusive), read from two cells in the worksheet.
Dim dtStartDate As Date, dtEndDate As Date
Dim lNdx As Long
Dim pvt As PivotTable
Dim sErrMsg As String
Dim vItemsToBeVisible As Variant
On Error GoTo ErrProc
With Application
.EnableCancelKey = xlErrorHandler
.ScreenUpdating = False
.DisplayStatusBar = False
.EnableEvents = False
End With
'--build array of dates to be shown after filtering
With Sheets("Sheet1")
dtStartDate = .Range("C4").Value
dtEndDate = .Range("C5").Value
End With
If dtStartDate > dtEndDate Then
sErrMsg = "End date must be after start date."
GoTo ExitProc
End If
ReDim vItemsToBeVisible(1 To dtEndDate - dtStartDate + 1)
For lNdx = LBound(vItemsToBeVisible) To UBound(vItemsToBeVisible)
'--edit the date format to match that used by your OLAP datasource
vItemsToBeVisible(lNdx) = Format(dtStartDate + lNdx - 1, "m-d-yyyy")
Next lNdx
'--if all PivotTables linked to Slicer, only need to change one.
'--otherwise, replace with code to step through each PivotTable.
Set pvt = Sheets("Sheet").PivotTables("PivotTable1")
sErrMsg = sOLAP_FilterByItemList( _
pvf:=pvt.PivotFields("[PL Accounting Date].[Yearly Calendar].[Year]"), _
vItemsToBeVisible:=vItemsToBeVisible, _
sItemPattern:="[PL Accounting Date].[Yearly Calendar].[Date].&[ThisItem]")
ExitProc:
On Error Resume Next
With Application
.EnableEvents = True
.DisplayStatusBar = True
.ScreenUpdating = True
End With
If Len(sErrMsg) > 0 Then MsgBox sErrMsg
Exit Sub
ErrProc:
sErrMsg = Err.Number & " - " & Err.Description
Resume ExitProc
End Sub
Private Function sOLAP_FilterByItemList(ByVal pvf As PivotField, _
ByVal vItemsToBeVisible As Variant, _
ByVal sItemPattern As String) As String
'--filters an OLAP pivotTable to display a list of items,
' where some of the items might not exist
'--works by testing whether each pivotitem exists, then building an
' array of existing items to be used with the VisibleItemsList property
'--requires Excel 2007 or later
'--Input Parameters:
' pvf pivotfield object to be filtered
' vItemsToBeVisible array of strings representing items to be visible
' sItemPattern string that has MDX pattern of pivotItem reference
' where the text "ThisItem" will be replaced by each
' item in vItemsToBeVisible to make pivotItem references.
' e.g.: "[tblSales].[product_name].&[ThisItem]"
Dim lFilterItemCount As Long, lNdx As Long
Dim vFilterArray As Variant
Dim vSaveVisibleItemsList As Variant
Dim sReturnMsg As String, sPivotItemName As String
'--store existing visible items
vSaveVisibleItemsList = pvf.VisibleItemsList
If Not (IsArray(vItemsToBeVisible)) Then _
vItemsToBeVisible = Array(vItemsToBeVisible)
ReDim vFilterArray(1 To _
UBound(vItemsToBeVisible) - LBound(vItemsToBeVisible) + 1)
pvf.Parent.ManualUpdate = True
'--check if pivotitem exists then build array of items that exist
For lNdx = LBound(vItemsToBeVisible) To UBound(vItemsToBeVisible)
'--create MDX format pivotItem reference by substituting item into pattern
sPivotItemName = Replace(sItemPattern, "ThisItem", vItemsToBeVisible(lNdx))
'--attempt to make specified item the only visible item
On Error Resume Next
pvf.VisibleItemsList = Array(sPivotItemName)
On Error GoTo 0
'--if item doesn't exist in field, this will be false
If LCase$(sPivotItemName) = LCase$(pvf.VisibleItemsList(1)) Then
lFilterItemCount = lFilterItemCount + 1
vFilterArray(lFilterItemCount) = sPivotItemName
End If
Next lNdx
'--if at least one existing item found, filter pivot using array
If lFilterItemCount > 0 Then
ReDim Preserve vFilterArray(1 To lFilterItemCount)
pvf.VisibleItemsList = vFilterArray
Else
sReturnMsg = "No matching items found."
pvf.VisibleItemsList = vSaveVisibleItemsList
End If
pvf.Parent.ManualUpdate = False
sOLAP_FilterByItemList = sReturnMsg
End Function
