VBA OLAP Pivot Filter for Array

[dversloot1]

Hello,

I've managed to filter OLAP Pivots before if the CurrentFieldName was one option. Now, I have a range of dates that cannot be selected using the between function because the OLAP Cube isn't set up that way. I've set up a date table in my workbook that has all the possible dates between a selected range from a combox in my userform.
The trick is that not all dates will be in the Cube. So I'm hoping to skip the ones that aren't in the pivot until the macro loops through all of my array.

Here is a recorded macro of what I would like to do:
Sub Macro4()
ActiveSheet.PivotTables("PivotTable3").PivotFields( _
"[PO Details].[PO Receipt].[PO Receipt]").VisibleItemsList = Array( _
"[PO Details].[PO Receipt].&[2015-01-06T00:00:00]", _
"[PO Details].[PO Receipt].&[2015-01-07T00:00:00]", _
"[PO Details].[PO Receipt].&[2015-01-08T00:00:00]", _
"[PO Details].[PO Receipt].&[2015-01-09T00:00:00]", _
"[PO Details].[PO Receipt].&[2015-01-10T00:00:00]", _
"[PO Details].[PO Receipt].&[2015-01-12T00:00:00]", _
"[PO Details].[PO Receipt].&[2015-01-13T00:00:00]")
End Sub

My attempt is the following but it doesn't handle errors (Date not in cube)

Sub Macro3()


Dim a, b, c, d, e, f, g As String


a = "[PO Details].[PO Receipt].&[" & Format(Application.WorksheetFunction.VLookup(UserForm1.CBDate.Value, Sheets("Lookup").Range("D:K"), 2, False), "yyyy-mm-dd") & "T00:00:00]"
b = "[PO Details].[PO Receipt].&[" & Format(Application.WorksheetFunction.VLookup(UserForm1.CBDate.Value, Sheets("Lookup").Range("D:K"), 3, False), "yyyy-mm-dd") & "T00:00:00]"
c = "[PO Details].[PO Receipt].&[" & Format(Application.WorksheetFunction.VLookup(UserForm1.CBDate.Value, Sheets("Lookup").Range("D:K"), 4, False), "yyyy-mm-dd") & "T00:00:00]"
d = "[PO Details].[PO Receipt].&[" & Format(Application.WorksheetFunction.VLookup(UserForm1.CBDate.Value, Sheets("Lookup").Range("D:K"), 5, False), "yyyy-mm-dd") & "T00:00:00]"
e = "[PO Details].[PO Receipt].&[" & Format(Application.WorksheetFunction.VLookup(UserForm1.CBDate.Value, Sheets("Lookup").Range("D:K"), 6, False), "yyyy-mm-dd") & "T00:00:00]"
f = "[PO Details].[PO Receipt].&[" & Format(Application.WorksheetFunction.VLookup(UserForm1.CBDate.Value, Sheets("Lookup").Range("D:K"), 7, False), "yyyy-mm-dd") & "T00:00:00]"
g = "[PO Details].[PO Receipt].&[" & Format(Application.WorksheetFunction.VLookup(UserForm1.CBDate.Value, Sheets("Lookup").Range("D:K"), 8, False), "yyyy-mm-dd") & "T00:00:00]"

ActiveSheet.PivotTables("PivotTable3").PivotFields( _
"[PO Details].[PO Receipt].[PO Receipt]").VisibleItemsList = Array(a, b, c, d, e, f, g)
End Sub

Can someone help me out?

Dan

 

[Jerry Sullivan]

Hi Dan,

One way to handle that is to test each item to see if it exists in the PivotField of the Cube. You can use a function like this...

Private Function bPivotItemExists(ByVal pvf As PivotField, _
   ByVal sItemName As String, _
   Optional ByVal bReset As Boolean = False) As Boolean

'--returns True if a pivotitem exists in a pivotfield else False
'  only applicable to OLAP PivotTables

 Dim bReturn As Boolean
 Dim vSaveVisibleItemsList As Variant
 
 With pvf
   '--store existing items
   If bReset Then vSaveVisibleItemsList = .VisibleItemsList
   
   On Error Resume Next
   '--attempt to make specified item the only visible item
   .VisibleItemsList = Array(sItemName)
   On Error GoTo 0
   '--if the item doesn't exist in field, this will be false
   bReturn = sItemName = .VisibleItemsList(1)
   
   '--restore previously visible items-if optional argument bReset=True
   If bReset Then .VisibleItemsList = vSaveVisibleItemsList
 End With
 
 '--return result
 bPivotItemExists = bReturn
 
End Function

Your calling procedure can build an array consisting of only the items that have been found to exist. That array can be used to set the VisibleItemsList as you were trying to do with the entire list.

Here's an example...

Sub FilterOLAP()
'--example showing one way to filter a pivot using an OLAP datasource
'  to display a list of items, where some of the items might not exist

'  uses the function bPivotItemExists to test if each item exists then
'  builds an array of items that do exist

 Dim lFilterCount As Long, lNdx As Long
 Dim pvt As PivotTable
 Dim pvf As PivotField
 Dim sPO As String, sDateString As String, sErrMsg As String
 Dim vRow As Variant, vDateList As Variant, vFilterArray As Variant
 
 Set pvt = ActiveSheet.PivotTables("PivotTable3")
 Set pvf = pvt.PivotFields("[PO Details].[PO Receipt].[PO Receipt]")
 
 On Error GoTo ErrProc
 
 sPO = UserForm1.CBDate.Value
 vRow = Application.Match(sPO, Sheets("Lookup").Range("D:D"), 0)
 
 If IsError(vRow) Then
   MsgBox "PO " & sPO & " not found in lookup."
   Exit Sub
 End If
 
 '--read dates from PO record into array
 vDateList = Sheets("Lookup").Cells(CLng(vRow), "E").Resize(1, 7)

 ReDim vFilterArray(1 To 7)
 '--check if pivotitem exists in cube for each date.
 '  build array of pivotitem that do exist
 For lNdx = 1 To 7
   sDateString = "[PO Details].[PO Receipt].&[" & _
      Format(vDateList(lNdx, 2), "yyyy-mm-dd") & "T00:00:00]"
   If bPivotItemExists(pvf:=pvf, sItemName:=sDateString) Then
      lFilterCount = lFilterCount + 1
      vFilterArray(lFilterCount) = sDateString
   End If
 Next lNdx
 
 '--if at least one existing item found, filter pivot using array
 If lFilterCount = 0 Then
   MsgBox "No matching items found."
 Else
   ReDim Preserve vFilterArray(1 To lFilterCount)
   pvf.VisibleItemsList = vFilterArray
 End If

ExitProc:
 On Error Resume Next
 If Len(sErrMsg) > 0 Then MsgBox sErrMsg
 Exit Sub
 
ErrProc:
 sErrMsg = Err.Number & " - " & Err.Description
 Resume ExitProc
End Sub

 

[dversloot1]

Thank you for the reply, Jerry.
The code seems to work but only for the first date in the array. lNdx of 2 or greater I'm taken to ErrProc. There should be 4-5 records found per date range.
Any ideas why ?

The error comes from here when the second range in the array is added to the string

sDateString = "[PO Details].[PO Receipt].&[" & _
Format(vDateList(lNdx, 2), "yyyy-mm-dd") & "T00:00:00]"

 

[Jerry Sullivan]

Hmm...I'm not sure why that error would occur if you used the code I suggested without modifying it.

To narrow down the problem, modify as shown below to comment out the error hander and add a few debug.print statements that will help with debugging.

[B][COLOR="#0000CD"]'''' [/COLOR][/B]On Error GoTo ErrProc
 
 sPO = UserForm1.CBDate.Value
 vRow = Application.Match(sPO, Sheets("Lookup").Range("D:D"), 0)
 
 If IsError(vRow) Then
   MsgBox "PO " & sPO & " not found in lookup."
   Exit Sub
 End If
 
 '--read dates from PO record into array
 vDateList = Sheets("Lookup").Cells(CLng(vRow), "E").Resize(1, 7).[B][COLOR="#0000CD"]Value[/COLOR][/B]
 
[COLOR="#0000CD"][B] Debug.Print "Rows: " & UBound(vDateList)
 Debug.Print "Columns: " & UBound(vDateList)[/B][/COLOR]
 

 ReDim vFilterArray(1 To 7)

The behavior you describe is what often happens when a code tries to access a element outside the boundaries of an array.

By commenting out the error handler, you'll find out the type of error- most likely it's
"Subscript out of range"

If that's the case, post the information printed to the Immediate Window of your VB Editor.
It should read:
Rows: 1
Columns: 7

 

[dversloot1]

Jerry,
Here is the information printed to the Immediate Window before it stopped.

Rows: 1
Columns: 1

When lNdx is 2, the sDateString sends the macro to ErrProc:

I copied exactly what you had.

Private Function bPivotItemExists(ByVal pvf As PivotField, _
ByVal sItemName As String, _
Optional ByVal bReset As Boolean = False) As Boolean


'--returns True if a pivotitem exists in a pivotfield else False
' only applicable to OLAP PivotTables


Dim bReturn As Boolean
Dim vSaveVisibleItemsList As Variant

With pvf
'--store existing items
If bReset Then vSaveVisibleItemsList = .VisibleItemsList

On Error Resume Next
'--attempt to make specified item the only visible item
.VisibleItemsList = Array(sItemName)
On Error GoTo 0
'--if the item doesn't exist in field, this will be false
bReturn = sItemName = .VisibleItemsList(1)

'--restore previously visible items-if optional argument bReset=True
If bReset Then .VisibleItemsList = vSaveVisibleItemsList
End With

'--return result
bPivotItemExists = bReturn

End Function


Sub FilterOLAP()
'--example showing one way to filter a pivot using an OLAP datasource
' to display a list of items, where some of the items might not exist


' uses the function bPivotItemExists to test if each item exists then
' builds an array of items that do exist


Dim lFilterCount As Long, lNdx As Long
Dim pvt As PivotTable
Dim pvf As PivotField
Dim sPO As String, sDateString As String, sErrMsg As String
Dim vRow As Variant, vDateList As Variant, vFilterArray As Variant

Set pvt = ActiveSheet.PivotTables("PivotTable3")
Set pvf = pvt.PivotFields("[PO Details].[PO Receipt].[PO Receipt]")

On Error GoTo ErrProc

sPO = UserForm1.CBDate.Value
vRow = Application.Match(sPO, Sheets("Lookup").Range("D:D"), 0)

If IsError(vRow) Then
MsgBox "PO " & sPO & " not found in lookup."
Exit Sub
End If

'--read dates from PO record into array
vDateList = Sheets("Lookup").Cells(CLng(vRow), "E").Resize(1, 7).Value

Debug.Print "Rows: " & UBound(vDateList)
Debug.Print "Columns: " & UBound(vDateList)

ReDim vFilterArray(1 To 7)
'--check if pivotitem exists in cube for each date.
' build array of pivotitem that do exist
For lNdx = 1 To 7
sDateString = "[PO Details].[PO Receipt].&[" & _
Format(vDateList(lNdx, 2), "yyyy-mm-dd") & "T00:00:00]"
If bPivotItemExists(pvf:=pvf, sItemName:=sDateString) Then
lFilterCount = lFilterCount + 1
vFilterArray(lFilterCount) = sDateString
End If
Next lNdx

'--if at least one existing item found, filter pivot using array
If lFilterCount = 0 Then
MsgBox "No matching items found."
Else
ReDim Preserve vFilterArray(1 To lFilterCount)
pvf.VisibleItemsList = vFilterArray
End If


ExitProc:
On Error Resume Next
If Len(sErrMsg) > 0 Then MsgBox sErrMsg
Exit Sub

ErrProc:
sErrMsg = Err.Number & " - " & Err.Description
Resume ExitProc

End Sub

 

[dversloot1]

Jerry,
Please note that my dates start in column E and go to Column K.
Column D has the dropdown menu reference.

 

[Jerry Sullivan]

Dan, I meant to write:

Debug.Print "Rows: " & UBound(vDateList[B],1[/B])
Debug.Print "Columns: " & UBound(vDateList[B],2[/B])

Also, when you run this again after commenting out the error hander, what error message is displaying when the code stops?

 

[dversloot1]

Jerry,
I'm getting a 9 - Subscript out of Range error

Immediate Window:
Rows: 1
Columns: 1

 

[Jerry Sullivan]

Well, there should be a range of 1 row by 7 columns getting read into the array.

Please try adding this additional debugging code to help find where that is going wrong...

 '--read dates from PO record into array
[COLOR="#0000FF"] Dim rRecord As Range, rCell As Range
 Set rRecord = Sheets("Lookup").Cells(CLng(vRow), "E").Resize(1, 7)
 
 Debug.Print rRecord.Address
 For Each rCell In rRecord
   Debug.Print rCell.Value
 Next rCell[/COLOR]
 vDateList = Sheets("Lookup").Cells(CLng(vRow), "E").Resize(1, 7).Value

 

[dversloot1]

Rows: 1
Columns: 1
$E$3:$K$3
1/4/2015
1/5/2015
1/6/2015
1/7/2015
1/8/2015
1/9/2015
1/10/2015

Seems to be looking at the correct range.

Subscript out of Range Error if the macro continues.

The error occurs around the code where it attempts to add a second record to the filter.