Olap filter on dates using VBA and custom Date filter

[EhhMikey]

Hello Mr Excel,

I have a tricky VBA code I'm trying to figure out, but cannot quite get the code to recognize my code for the dates. I'll try to clarify my issue and show blogs I've tried.

I've build a table that includes 12-20 dates in the format YYYY-PMM so "Year"- "P" (Period) and "month", i.e. 2017-P08 would be this month. I've tried to use the code in this thread: https://www.mrexcel.com/forum/excel...vot-table-off-multiple-reference-cells-3.html. But it doesn't seem to be working for dates. I found some information that I need to change my dates to strings (Filtering OLAP Pivots by Date Variables/Ranges Please help) but it still doesn't seem to be working. i.e.

    ActiveSheet.PivotTables("PivotTable3").PivotFields( _        "[Date].[Date by Fiscal YQPWD].[FiscalYear]").ClearAllFilters
    ActiveSheet.PivotTables("PivotTable3").PivotFields( _
        "[Date].[Date by Fiscal YQPWD].[FiscalYear]").CurrentPageName = _
        "[Date].[Date by Fiscal YQPWD].[FiscalYear].&[2017].&[2017-FQ1].&[2017-P01]"

I'm currently running the following 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  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

Calling the data with the following Marco

Sub CallingExample()'--example showing call to function sOLAP_FilterByItemList


Dim ws As Worksheet
 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
   
 '--read filter items from worksheet table
 vItemsToBeVisible = Application.Transpose( _
   ActiveSheet.ListObjects("DateFilter").DataBodyRange.Value)


 Set pvt = Sheets("Summary").PivotTables("PivotTable3")
 '--call function
 sErrMsg = sOLAP_FilterByItemList( _
   pvf:=pvt.PivotFields("[Date].[Date by Fiscal YQPWD].[FiscalYear]"), _
   vItemsToBeVisible:=vItemsToBeVisible, _
   sItemPattern:="[Date].[Date by Fiscal YQPWD].[FiscalYear].&[" & FiscalYear & "]&[" & FiscalQuarterOfFiscalYear & "]&[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

I believe the error is here: sItemPattern:="[Date].[Date by Fiscal YQPWD].[FiscalYear].&[" & FiscalYear & "]&[" & FiscalQuarterOfFiscalYear & "]&[ThisItem]")

But I'm not sure what combination I need to run in order to get my formatting correct (If that's even the issue)

Error: 1004 - Application-defined or object-defined error

Any help is greatly appreciated!!! I know this is quite long, but I wanted to include all details.