Selecting String/Value range in an OLAP slicer using macro

[JN13BH]

Hello,
I am trying to adapt this VBA code to select a range of values that are in text format. These values represent zip codes. Some zip codes exist within the OLAP fields and some do not. I'm having some issues adapting this existing VBA code to fit my need.

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

Sub FilterPivotForWeek()
 Dim dtStart As Variant
 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("UMD Demand Calendara 4.13.16.xlsm").Sheets("Cube Data Middlesex MA").Range("BU1").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, "#####")
      Debug.Print Format(dtStart, "#####")
    Next lDay
 
   
    Set pvt = ThisWorkbook.Sheets("Cube Data Middlesex MA").PivotTables("PivotTable2")
    '--call function
    sErrMsg = sOLAP_FilterByItemList( _
      pvf:=pvt.PivotFields("[FactDemandDW].[Emp Home Zip Code].[Emp Home Zip Code]"), _
      vItemsToBeVisible:=vItemsToBeVisible, _
      sItemPattern:="[FactDemandDW].[Emp Home Zip Code].&[ThisItemT#####]")
 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

 

[Jerry Sullivan]

Please use the macro recorder to record your actions while you manually filter the PivotTable for 2-3 items.

If you'll post the resulting code, I'll try to help you adapt it.

Also, are you using US Regional Settings for Dates or something else?

Edit: In looking at your code, I think your references to dates are just left over from the code you are trying to adapt. If you are just trying to filter for a list of zip codes in a range, you can disregard my question about Regional Settings. Do clarify where range of Zip codes can be found.

 

[JN13BH]

Hi Jerry,
You are correct that the reference to dates was just left over. I kept that as a variable but tried to adapt it to my purpose.

The range of zips currently is in Column BU starting in BU1. A named range is also a possibility. Any name would work.

Here is a sample of the code generated when recording the macro to filter the OLAP pivot visible item list. I made a couple of changes at a time, adding new facts to show the progression.

"
ActiveSheet.PivotTables("PivotTable2").PivotFields( _
"[FactDemandDw].[Emp Home Zip Code].[Emp Home Zip Code]").VisibleItemsList = _
Array("", "", "", "", "", "", "", "", "", "", _
"[FactDemandDw].[Emp Home Zip Code].&[ 55076]", _
"[FactDemandDw].[Emp Home Zip Code].&[ 55409]", _
"[FactDemandDw].[Emp Home Zip Code].&[ 60515]", _
"[FactDemandDw].[Emp Home Zip Code].&[94510]", _
"[FactDemandDw].[Emp Home Zip Code].&[94533]", _
"[FactDemandDw].[Emp Home Zip Code].&[94534]", _
"[FactDemandDw].[Emp Home Zip Code].&[94535]", _
"[FactDemandDw].[Emp Home Zip Code].&[94585]", _
"[FactDemandDw].[Emp Home Zip Code].&[94589]", _
"[FactDemandDw].[Emp Home Zip Code].&[94590]", _
"[FactDemandDw].[Emp Home Zip Code].&[94591]", _
"[FactDemandDw].[Emp Home Zip Code].&[95687]", _
"[FactDemandDw].[Emp Home Zip Code].&[95688]")
ActiveSheet.PivotTables("PivotTable2").PivotFields( _
"[FactDemandDw].[Emp Home Zip Code].[Emp Home Zip Code]").VisibleItemsList = _
Array("[FactDemandDw].[Emp Home Zip Code].&[48050]", "", "", _
"[FactDemandDw].[Emp Home Zip Code].&[48066]", "", "", "", "", "", "", "", "", "", "", _
"[FactDemandDw].[Emp Home Zip Code].&[ 55076]", _
"[FactDemandDw].[Emp Home Zip Code].&[ 55409]", _
"[FactDemandDw].[Emp Home Zip Code].&[ 60515]", _
"[FactDemandDw].[Emp Home Zip Code].&[48051]", _
"[FactDemandDw].[Emp Home Zip Code].&[48065]", _
"[FactDemandDw].[Emp Home Zip Code].&[94510]", _
"[FactDemandDw].[Emp Home Zip Code].&[94533]", _
"[FactDemandDw].[Emp Home Zip Code].&[94534]", _
"[FactDemandDw].[Emp Home Zip Code].&[94535]", _
"[FactDemandDw].[Emp Home Zip Code].&[94585]", _
"[FactDemandDw].[Emp Home Zip Code].&[94589]", _
"[FactDemandDw].[Emp Home Zip Code].&[94590]", _
"[FactDemandDw].[Emp Home Zip Code].&[94591]", _
"[FactDemandDw].[Emp Home Zip Code].&[95687]", _
"[FactDemandDw].[Emp Home Zip Code].&[95688]")
ActiveWindow.SmallScroll Down:=-27
ActiveSheet.PivotTables("PivotTable2").PivotFields( _
"[FactDemandDw].[Emp Home Zip Code].[Emp Home Zip Code]").VisibleItemsList = _
Array("[FactDemandDw].[Emp Home Zip Code].&[48050]", "", "", _
"[FactDemandDw].[Emp Home Zip Code].&[48066]", _
"[FactDemandDw].[Emp Home Zip Code].&[74021]", _
"[FactDemandDw].[Emp Home Zip Code].&[74029]", _
"[FactDemandDw].[Emp Home Zip Code].&[74037]", "", "", "", "", "", "", "", "", "", "", _
"[FactDemandDw].[Emp Home Zip Code].&[ 55076]", _
"[FactDemandDw].[Emp Home Zip Code].&[ 55409]", _
"[FactDemandDw].[Emp Home Zip Code].&[ 60515]", _
"[FactDemandDw].[Emp Home Zip Code].&[48051]", _
"[FactDemandDw].[Emp Home Zip Code].&[48065]", _
"[FactDemandDw].[Emp Home Zip Code].&[94510]", _
"[FactDemandDw].[Emp Home Zip Code].&[94533]", _
"[FactDemandDw].[Emp Home Zip Code].&[94534]", _
"[FactDemandDw].[Emp Home Zip Code].&[94535]", _
"[FactDemandDw].[Emp Home Zip Code].&[94585]", _
"[FactDemandDw].[Emp Home Zip Code].&[94589]", _
"[FactDemandDw].[Emp Home Zip Code].&[94590]", _
"[FactDemandDw].[Emp Home Zip Code].&[94591]", _
"[FactDemandDw].[Emp Home Zip Code].&[95687]", _
"[FactDemandDw].[Emp Home Zip Code].&[95688]")
End Sub


"

 

[Jerry Sullivan]

I've been offline for a few days. Sorry that it's taken me so long to get back to you.

Here's a Sub that you can use to call the function sOLAP_FilterByItemList.
Delete your Sub "FilterPivotForWeek" and use this instead.

The code assumes you have a range named "ZipsList" on the same sheet as your Pivot that holds the list of PivotItems to be visible.

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

 Dim pvt As PivotTable
 Dim sErrMsg As String, sTemplate As String
 Dim vItemsToBeVisible As Variant
 Dim wksPivots As Worksheet
 
 On Error GoTo ErrProc
 With Application
   .EnableCancelKey = xlErrorHandler
   .ScreenUpdating = False
   .DisplayStatusBar = False
   .EnableEvents = False
 End With
   
 Set wksPivots = ActiveSheet 'or Sheets("Sheet1")
 
 '--read filter items from dynamic named range
 vItemsToBeVisible = Application.Transpose( _
   wksPivots.Range("ZipsList").Value)

 Set pvt = wksPivots.PivotTables("PivotTable2")

 '--call function
 sErrMsg = sOLAP_FilterByItemList( _
   pvf:=pvt.PivotFields("[FactDemandDw].[Emp Home Zip Code].[Emp Home Zip Code]"), _
   vItemsToBeVisible:=vItemsToBeVisible, _
   sItemPattern:="[FactDemandDw].[Emp Home Zip Code].&[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

There's a space in front of some of the zip codes in your recorded macro that may cause a mismatch. Your zip codes in the named range will need to have that leading space for those same items or else the code will need to be more complex to test for both scenarios.