I hope it's not too late for me to contribute an answer, just for posterity's sake.
If you look at the PivotTable.MDX property on any OLAP PivotTable, you can see the MDX query which Excel is actually using behind the scenes to populate the data which shows up in the PivotTable. Inspired somewhat by this observation, I thought to myself: shouldn't it be possible to be even sneakier, by (a) creating an ADODB connection with the same connection string which the PivotCache uses, (b) putting together an appropriate MDX query ourselves, and (c) reading the result directly into an array in VBA, to which we can then assign the PivotField.VisibleItemsList property?
Benefits of this approach include...
- Avoiding the overhead and awkwardness of having to create & destroy a temporary PivotTable to get the full list of items;
- Handling OLAP PivotFields correctly which have more than 1,048,575 members--putting these on Rows with the temporary-PivotTable approach would cause an error, as the PivotTable would exceed the maximum number of rows on a Worksheet; and,
- Using an MDX query that's a bit faster and more efficient than the one Excel would most likely use by default.
Without further ado (or perhaps with further ADO? hehe), here's the VBA subroutine I came up with.
' Filter a PivotField in an OLAP PivotTable on either Visible or Hidden items.
Public Sub FilterOLAPPivotField(oPF As PivotField, vItems As Variant, _
Optional ByVal bVisible As Boolean = True)
Dim dictItems As Object
Dim i As Long
Dim sConn As String, sConnItems() As String
Dim sCatalog As String
Dim sQuery As String
Dim oConn As Object
Dim oRS As Object
Dim vRecordsetRows As Variant
Dim dictVisibleItems As Object
' In case something fails while we still have the ADODB Connection or Recordset
' open, this ensures the subroutine will "fail gracefully" and still close them.
' Feel free to add some more error handling if you like!
On Error GoTo Fail
' Turn on "checkbox mode" for selecting more than one filter item, for convenience.
oPF.CubeField.EnableMultiplePageItems = True
' If filtering on Visible items: then we just need to set the PivotField's
' VisibleItemsList property to the vItems array, and we can skip the rest.
If bVisible Then
oPF.VisibleItemsList = vItems
Exit Sub
End If
' All the rest of this subroutine is just for the case where we want our vItems
' to be the *Hidden* items, i.e. so everything *but* those items is visible.
' Read vItems into a Scripting.Dictionary. This is for convenience; we want to use
' its Exists method later. We only really care about the Keys; the Item:=True
' is just a dummy.
Set dictItems = CreateObject("Scripting.Dictionary")
For i = LBound(vItems) To UBound(vItems)
dictItems.Add Key:=vItems(i), Item:=True
Next i
' Get the connection string from the PivotCache of the PivotField's parent PivotTable
' (This assumes it is an OLEDB connection.)
' The connection string is needed to make a separate connection to the server
' with ADODB. It also contains the Initial Catalog, which we also need.
sConn = Replace$(oPF.Parent.PivotCache.Connection, "OLEDB;", vbNullString, Count:=1)
sConnItems = Split(sConn, ";")
For i = LBound(sConnItems) To UBound(sConnItems)
If sConnItems(i) Like "Initial Catalog=*" Then
sCatalog = "[" & Split(sConnItems(i), "=")(1) & "]"
Exit For
End If
Next i
' Construct an MDX query to send to the server, which just gets the UNIQUE_NAME of
' all the members in the hierarchy we're interested in.
sQuery = Join$(Array( _
"WITH MEMBER [Unique Name] AS", _
oPF.CubeField.Name & ".CURRENTMEMBER.UNIQUE_NAME", _
"SELECT [Unique Name] ON 0,", _
oPF.Name, "ON 1 FROM", _
sCatalog _
))
' Using ADODB, get the result of the query, and dump it into a Variant array.
Set oConn = CreateObject("ADODB.Connection")
Set oRS = CreateObject("ADODB.Recordset")
oConn.Open sConn
oRS.Open sQuery, oConn
vRecordsetRows = oRS.GetRows()
' The Recordset rows are a multidimensional array with 2 columns: column 0 contains
' the member captions, and column 1 (which is the one we want) contains the unique names.
' So we loop through the result, adding any member which was *not* in vItems to
' a new Scripting.Dictionary.
Set dictVisibleItems = CreateObject("Scripting.Dictionary")
For i = 0 To oRS.RecordCount - 1
If Not dictItems.Exists(vRecordsetRows(1, i)) Then
dictVisibleItems.Add Key:=vRecordsetRows(1, i), Item:=True
End If
Next i
' dictVisibleItems.Keys now contains all member which were *not* in vItems.
' All that remains is to set the PivotField's VisibleItemsList to this array!
oPF.VisibleItemsList = dictVisibleItems.Keys
Fail:
' Last but not least: don't forget to close the ADODB Connection and Recordset.
' If we got to this point normally, then (despite the 'Fail' label) we just close
' them uneventfully and end.
' If we jumped here because of an error, then we see a MsgBox at this point, but the
' subroutine will try to "fail gracefully" and still close the Connection & Recordset.
' Just in case we somehow ended up down here via an error raised *before* the
' Connection or Recordset was ever open, we also have "On Error Resume Next".
' Otherwise, the Close method itself might raise an error, sending us back to 'Fail'
' and trapping the subroutine in an infinite loop!
If Err Then
MsgBox "Something went horribly wrong", vbCritical, "Error"
Err.Clear
End If
On Error Resume Next
oRS.Close
oConn.Close
End Sub
If you're interested in using it in your own Workbook, then just copy it into a standard module, and call it with the relevant arguments.
For example: FilterOLAPPivotField(ActiveCell.PivotField, Items, False) would filter the PivotField under the active cell so that it contains all items except those in the Items array.
An oddity I observed while testing this on my machine: sometimes, CubeField.EnableMultiplePageItems seems to think it's a read-only property if I have just opened a Workbook with a PivotField I'm trying to manipulate. Because the subroutine writes to this property, this can cause it to fail. Clicking once in the UI to open the filter dropdown always seems to make the problem go away. Not sure exactly what's behind this... maybe the PivotCache is not loading until I actually interact with the PivotTable? If anyone else has some insight, I'd be quite interested to learn about what causes this.
One last side note: if you plan on doing some manual finagling of a bunch of PivotFields on an existing Excel Workbook, then one thing you might also consider would be to put a button on your Quick Access Toolbar which just inverts all the filters on the PivotField under the active cell, i.e. which includes everything that's currently filtered & filters everything that's currently included. Or, you might want to have a UserForm with a CommandButton which does something similar. You could use the above subroutine to create such a button, by having another sub which calls it, like so:
' Invert the filters on the OLAP PivotField under the active cell.
Public Sub btnInvertOLAPPivotFieldFilter_Click()
Dim oPF As PivotField
Set oPF = ActiveCell.PivotField
oPF.CubeField.EnableMultiplePageItems = True
FilterOLAPPivotField oPF, oPF.VisibleItemsList, False
End Sub
