OLAP VBA Filter

[dml5055]

Hi,

I was able to create some code that will create an array and filter the OLAP field with the list of items in the array. However I have not found a solution to exclude items which are not in the field. I am getting the 1004 Error "The item could not be found in the OLAP Cube".

I have tried searching for solution but haven't really found a simple answer for the code to exclude items that don't exist. Below is the code I'm using to populate the array and filter on OLAP. Any help on fixing the error would be greatly appreciated!

Thanks,
Dan

Sub OLAP_Filter2()
 Dim myArray() As Variant
 Dim myR As Range
 
 
 
 Set myR = Sheets(13).Range("A6", Sheets(13).Range("A6").End(xlDown))
 
 
 
 
 ReDim myArray(0 To myR.Cells.Count - 1)
 
 'Populate the array
 
 For i = 0 To myR.Cells.Count - 1
 myArray(i) = "[Product].[SKU Nbr].&[" & myR.Cells(i + 1).Value & "]"
 Next i
 
 ThisWorkbook.Sheets("OLAP").PivotTables("PivotTable5").PivotFields( _
 "[Product].[SKU Nbr].[SKU Nbr]").VisibleItemsList = myArray
 
 
 
 
 
 End Sub

 

[Jerry Sullivan]

Hi Dan,

Here a function I wrote for that purpose that Bill Jelen (MrExcel), Tracy Syrstad (Starl) were kind to include in their recent book: Excel 2016 VBA and Macros

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

Here is a example of how that function can be called, that you could adapt for your scenario.

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

 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( _
   wksPivots.ListObjects("tblVisibleItemsList").DataBodyRange.Value)

 Set pvt = wksPivots.PivotTables("PivotTable1")
 '--call function
 sErrMsg = sOLAP_FilterByItemList( _
   pvf:=pvt.PivotFields("[tblSales].[product_name].[product_name]"), _
   vItemsToBeVisible:=vItemsToBeVisible, _
   sItemPattern:="[tblSales].[product_name].&[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

 

[dml5055]

Thanks, I was able to get this to work, but what caused me some trouble was having the

[FONT=Verdana]vItemsToBeVisible = Application.Transpose( _[/FONT]  
 wksPivots.ListObjects("tblVisibleItemsList").DataBodyRange.Value)

need to run as a table. I'm able to modify my file to use a table, but I'm curious how I would get this to work if I kept it as a range instead of using a table?

Thanks again Jerry!

 

[Jerry Sullivan]

Dan, I'm glad you were able to figure out how to adapt that. The function assumes that the variable vItemsToBeVisible holds a 1-D array, so Transpose is used to convert a 2-Range of values into that 1-D array.

Here's an example of how to read a list of items from a worksheet where the number of items may vary.

 Dim lLastRow As Long
 
 With Sheets("Sheet2")
   lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   
   vItemsToBeVisible = Application.Transpose( _
      .Range("A2:A" & lLastRow).Value)
 End With

 

[RolandKol]

Hi Guys,

I have tried to apply/amend this code to my needs, but I lack of knowledge probably...
At the end, filter selects only 0 values and does not select any other values...

In fact, I am trying do completely opposite, - to set up Filter to choose all Values except BLANKs and Zeros and the Pivot table below have to count Unique Values... it is the second week I am on it without any luck....
As I understand the code above my post creates the string with all values, however it is not able to handle values which are higher then 10, as a Filter string has to include "E1", which is absent in this code.

Maybe you guys are able to help.

The main problem is with the code row "ActiveSheet.PivotTables("reportPivot").PivotFields("

#VALUE!

 

[Jerry Sullivan]

Hi Roland,

You are correct in observing that the items that you list in vItemsToBeVisible will be shown after the filtering. The code examples above can't be used to do the opposite of hiding the items in vItemsToBeVisible and showing all the other items.

Here's a separate function, "sOLAP_FilterByHiddenItemList", that I've modified to perform the objective you describe.

Private Function sOLAP_FilterByHiddenItemList(ByVal pvf As PivotField, _
   ByVal vItemsToBeHidden As Variant, _
   ByVal sItemPattern As String)
  
'--filters a field in an OLAP pivotTable to show all items except those
'    in the supplied 1-D array of items.
'--works by removing the items in vItemsToBeHidden from an array of items
'    stored in the pvf.VisibleItemsList after clearing all filters.
'--requires Excel 2007 or later

'--Input Parameters:
'  pvf                pivotfield object to be filtered
'  vItemsToBeHidden  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 vItemsToBeHidden to make pivotItem references.
'                     e.g.: "[tblSales].[product_name].&[ThisItem]"

 Dim dctAllItems As Object
 Dim lNdx As Long
 Dim pvi As PivotItem
 Dim sReturnMsg As String, sPivotItemName As String
 Dim sItem As String, s As String, sItemToHide As String
 Dim vSaveVisibleItemsList As Variant
 
 Set dctAllItems = CreateObject("Scripting.Dictionary")

 '--store existing visible items
 vSaveVisibleItemsList = pvf.VisibleItemsList
  
 If Not (IsArray(vItemsToBeHidden)) Then _
   vItemsToBeHidden = Array(vItemsToBeHidden)

 pvf.ClearAllFilters
 pvf.Parent.ManualUpdate = True
 
 '--write all existing pivotitems in this field into a dictionary
 For Each pvi In pvf.PivotItems
   sItem = pvi.Name
   s = dctAllItems.Item(sItem)
 Next pvi
 
 '--remove from dictionary and items to be hidden
 For lNdx = LBound(vItemsToBeHidden) To UBound(vItemsToBeHidden)
    '--create MDX format pivotItem reference by substituting item into pattern
   sItemToHide = vItemsToBeHidden(lNdx)
   
   If sItemToHide = vbNullString Or sItemToHide = "(blank)" Then
      sPivotItemName = Replace(sItemPattern, "[ThisItem]", vbNullString)
   Else
      sPivotItemName = Replace(sItemPattern, "ThisItem", sItemToHide)
   End If
      
   If dctAllItems.Exists(sPivotItemName) Then
      dctAllItems.Remove sPivotItemName
   End If
 Next lNdx
 
 If dctAllItems.Count = 0 Then
   '--cancel, restore saved filters and warn user
   pvf.VisibleItemsList = vSaveVisibleItemsList
   MsgBox "Must have at least one PivotItem visible after applying filters", _
      vbCritical, Title:="Filtering process canceled"
 Else
   '--apply filter using array of keys
   pvf.VisibleItemsList = dctAllItems.Keys
 End If

 pvf.Parent.ManualUpdate = False

 sOLAP_FilterByHiddenItemList = sReturnMsg
End Function

Below is an example Sub that calls that function. I've modified this Sub to use the Pivot and field names you provided in your post.

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

 Dim lLastRow As Long
 Dim pvt As PivotTable
 Dim sErrMsg As String, sTemplate As String
 Dim vItemsToBeHidden As Variant


 On Error GoTo ErrProc
 With Application
   .EnableCancelKey = xlErrorHandler
   .ScreenUpdating = False
   .DisplayStatusBar = False
   .EnableEvents = False
 End With
   
 '--read filter items from worksheet range
 With ActiveSheet
   lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   
   vItemsToBeHidden = Application.Transpose( _
      .Range("A2:A" & lLastRow).Value)
 End With

 Set pvt = ActiveSheet.PivotTables("reportPivot")
 '--call function
 sErrMsg = sOLAP_FilterByHiddenItemList( _
   pvf:=pvt.PivotFields("[Range].[TOTAL].[TOTAL]"), _
   vItemsToBeHidden:=vItemsToBeHidden, _
   sItemPattern:="[Range].[TOTAL].&[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

Regarding the handling of blanks, in my mockup of your scenario, I find that the full MDX field name for item 0 is consistent with the other values:
"

#VALUE!

 

[RolandKol]

Thank you very much for your time Jerry Sullivan .

It looks like you are the only one person online who shares experience on this field.


Please accept my apologies for bothering you.

As per your solution,
It looks like your Function is close, but not working yet unfortunately...

I simply redirected lLastRow and vItemsToBeHidden to collect data from different sheet in the same workbook and to column K, which holds figures formatted as General (1,2,4,40,42 ant etc).

I have noticed that at the start vItemsToBeHidden works correctly, it collects all (including blanks and Zero) values into Array,

but later, in the function, something fails... Sadly I cannot understand what...

In the Break Mode, -
during the removal of the Nil and Blank values from the Array the following values are constant:
pvi = nothing
sitem are always ""
and ofcourse....
dctAllItems.count=0

sPivotItemName and sItemToHide are changing values as expected...

Later I have made an experiment,
I have adjusted my original source data: changed all blanks cells to 0, and before calling the Function, removed all 0 values from the Array vItemsToBeHidden by

  For lngIndex = LBound(OrigArray) To UBound(OrigArray)
        If OrigArray(lngIndex) <> 0 Then
            If lngNItems = 0 Then
                ReDim vItemsToBeHidden(lngNItems)
            Else
                ReDim Preserve vItemsToBeHidden(lngNItems)
            End If
            vItemsToBeHidden(lngNItems) = OrigArray(lngIndex)
            lngNItems = lngNItems + 1
        End If
    Next

vItemsToBeHidden - was generated correctly, only figures, no blanks no Zeros, so after this I have called to your Function which I have amended by
commenting off the whole section '--remove from dictionary and items to be hidden

Function, as I understand, had to create Array of Strings with values from vItemsToBeHidden, but
no result...
dctAllItems.count=0


P.S.
If use small amount of data (40 rows) for the Pivot, - Macro recorder does not show any Scientific Notations.
However if I use data with aprox 1000 rows, Scientific Notations come back.

All experiments I did, I did with small amount of data to avoid problem with Scientific Notations

 

[Jerry Sullivan]

Hi Roland,

I think you are misunderstanding the steps that function is taking. The code does not attempt to remove any items from vItemsToBeHidden.

The main steps of the function are:
1. Clear all filters of the specified pivotfield
2. Transfer all pivotitems in that pivotfield to dictionary dctAllItems
3. Remove from dctAllItems any items that are contained in vItemsToBeHidden
4. If dctAllItems has any remaining items after step 3, apply filters to show those items.

From the breakpoint testing that you describe, I suspect the problem is that the block of code shown below isn't finding any items in pvf.PivotItems. That could be due to the field name not being an exact match. Try adding the two debug.print statements shown to check whether the pivotitem collection is being read.

 '--write all existing pivotitems in this field into a dictionary
 Debug.Print "Count: " & pvf.PivotItems.Count

 For Each pvi In pvf.PivotItems
   sItem = pvi.Name
   Debug.Print sItem
   s = dctAllItems.Item(sItem)
 Next pvi

 

[RolandKol]

Hi Again, debug gives Nill...
Count: 0

I have also checked what the Debug shows for Pivot Fields and Pivot Items with code:

Sub ShowPivotValues()
    Dim pt As PivotTable, pf As PivotField, pi As PivotItem
    Set pt = ActiveSheet.PivotTables(1)
    For Each pf In pt.PivotFields

        Debug.Print pf.Name
        For Each pi In pf.PivotItems
            Debug.Print , pi.Value
        Next
    Next
End Sub

Result:
'******************************

#VALUE!

 

[Jerry Sullivan]

Hi Roland,

Is your "

#VALUE!