Hi Cohen, Here's a general purpose function that can be used to filter a PivotTable with an OLAP data source to show and array of items. For your objective, we'll pass and array with the 7 dates.
Paste this into a Standard Code Module (like Module1) in your workbook POSODRBD.xlsm...
Code:
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 1D 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
Next, paste this Sub that calls the function into the same Standard Code Module.
Code:
Sub FilterPivotForWeek()
Dim dtStart As Date
Dim lDay As Long
Dim pvt As PivotTable
Dim sErrMsg As String, sTemplate As String
Dim vItemsToBeVisible As Variant
On Error GoTo ErrProc
With Application
.EnableCancelKey = xlErrorHandler
.ScreenUpdating = False
.DisplayStatusBar = False
.EnableEvents = False
End With
On Error Resume Next
dtStart = Workbooks("WFS.xlsx").Sheets("Calculations").Range("B10").Value
On Error GoTo 0
If dtStart = 0 Then
MsgBox "Error reading start date."
Else
'--create array of filter items for week beginning at dtStart
ReDim vItemsToBeVisible(0 To 6)
For lDay = 0 To 6
vItemsToBeVisible(lDay) = Format(dtStart + lDay, "YYYY-MM-DD")
Debug.Print Format(dtStart + lDay, "YYYY-MM-DD")
Next lDay
Set pvt = ThisWorkbook.Sheets("TOP 30 Dstn5").PivotTables(1)
'--call function
sErrMsg = sOLAP_FilterByItemList( _
pvf:=pvt.PivotFields("[Tbl_POS_OD_RBD_Bkgs].[BKG_DT].[BKG_DT]"), _
vItemsToBeVisible:=vItemsToBeVisible, _
sItemPattern:="[Tbl_POS_OD_RBD_Bkgs].[BKG_DT].&[ThisItemT00:00:00]")
End If
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
Test the code by running the macro "FilterPivotForWeek". This is untested since I can't easily replicate your setup.
If it works, then I'll suggest some code to automatically trigger running "FilterPivotForWeek". Since your workbook with the dates is not one that supports macros, and it's unclear to me whether B10 is being changed by user input, a simple approach would be to check the Start Date any time sheet "TOP 30 Dstn5" is activated and filter the pivot if that date has been changed.
