Selecting date range in a slicer using macro

[Cohen]

I would like to seek help regarding writing a macro that would automatically select slicer date range from a cell value from a different workbook.. I have 7-days date range that change every week.. Start date is on other workbook cell a1 and end date on a7. Hope you can help me

 

[jdmiranda]

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...

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.

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.

Hello Jerry,
I came across this thread when looking for a way to selecting a date range using a macro. I tested the code you provided here, and works excellent, but what I need is a date range like dtStart to dtEnd for example. More specifically, a two date ranges, like Before start to Before End, and After Start to After End. So I can compare two different time periods. Can this code be modified to be able to do that? If so, can you share your thoughts? Thank you so much!