Catching those slicer selections: A macro to do the work for you...

I've been working with PowerPivot for some time now and one thing that I've noticed on each of my solutions that I create is that I spend too much time creating the hidden sheet that "catches" each of the slicer selections that are active.  This can sometimes take hours if the project is big enough.

So, this last time, I decided to take 20 minutes out of my day do a little research on the Google and write a macro that would do exactly that for me.  Too much time is now almost no time at all and I have a bit of my work day back.  

Here is what I use. If you have suggestions on how to make it more efficient or just better practice (self-taught here folks!), please share in the comments!

Summary of Macro: 

Create a worksheet called "HiddenFilterCatch".  

Add Cubeset and CubeRankedMember formulas to new sheet (Prompting user for max number of options per slicer to catch)

Please excuse the blog formatting as I use a bit more screen real estate when coding.  Enjoy!

*Disclaimer - this worked for me in my specific scenario. You may/may not need to adjust the code to fit your situation.  :)

Option Explicit

Sub MultiplePivotSlicerCaches()

    Dim oSlicer As Slicer

    Dim oSlicercache As SlicerCache

    Dim oSh As Worksheet

    Dim SlcrName As String

    Dim Col As Integer 'Column Number

    Dim Connect As String, Comma As String, oPrn As String, cPrn As String 'Formula pieces

    Dim i As Integer 'Number of Slicers

    Dim Fmla As String 'Completed Formula

    Dim ws As Worksheet

    Dim x As Integer 'Max # of Filters determined by user

    Dim z As Variant

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual

    

'Add New Worksheet "HiddenFilterCatch"

    z = MsgBox("Do you have a 'HiddenFilterCatch' Worksheet already?", vbYesNo)

    If z = vbNo Then

        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))

        ws.Name = "HiddenFilterCatch"

    End If

'Count Slicers in Workbook (For Trouble Shooting Code Only)

    'i = 0

    'For Each oSlicercache In ThisWorkbook.SlicerCaches

    'i = i + 1

    'Next

    

'Set Variables for "=Cubeset()"

    Col = 3 'Column Number

    Connect = "=Cubeset(" & Chr(34) & "ThisWorkBookDataModel" & Chr(34) & ","

    Comma = ","

    oPrn = "("

    cPrn = ")"

    

       

'Distribute Cubeset Formulas onto spreadsheet

    Sheets("HiddenFilterCatch").Activate

    For Each oSlicercache In ThisWorkbook.SlicerCaches

            SlcrName = oSlicercache.Name

            Fmla = Connect & SlcrName & Comma & Chr(34) & SlcrName & Chr(34) & cPrn

            Cells(9, Col).Formula = Fmla

            Col = Col + 1

    Next

    

'Set Variables for "=CubeRankedMember()"

    Connect = "=IFERROR(CUBERANKEDMEMBER(" & Chr(34) & "ThisWorkBookDataModel" & Chr(34) & ","

    

'Distribute CubeRankedMember Formulas onto spreadsheet

    Col = 3

    x = InputBox(Prompt:="What is the Maximum Number of filters you would like to show?", Title:="Maximum Number of Filters", Default:="4")

    For Each oSlicercache In ThisWorkbook.SlicerCaches

            'Add formulas for CubeRankedMembers 1 to "x"

                For i = 1 To x

                    Fmla = Connect & Cells(9, Col).Value & ",Row(HiddenFilterCatch!A" & i & "))," & Chr(34) & Chr(34) & ")"

                    Cells(9 + i, Col).Formula = Connect & Cells(9, Col).Value & ",Row(HiddenFilterCatch!A" & i & "))," & Chr(34) & Chr(34) & ")"

                Next

            'Add "More than 'x' Selected..." Text formula

                Cells(10 + x, Col).Formula = "=IF(" & Right(Fmla, Len(Fmla) - 1) & "=" & Chr(34) & Chr(34) & "," & Right(Fmla, Len(Fmla) - 1) & "," & Chr(34) & "More Than " & x & " Selected..." & Chr(34) & ")"

            'Add named Range on Cell below "More Than" formula

                Cells(11 + x, Col).Select

                With Selection

                    .Name = Right(Cells(9, Col).Value, Len(Cells(9, Col).Value) - 7)

                End With

                Col = Col + 1

    Next

    Application.ScreenUpdating = True

    Application.Calculation = xlCalculationAutomatic

    

    

End Sub