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

SPEED UP YOUR VBA RunTime!

WOW!  I just found a nice little help that improved my vba run time from 30 minutes to less than 1 minute!

So, I had a bit of VBA that I wrote to clean up and group a transaction level data set from a 3rd party report.  I noticed that on average it was taking up to FOUR seconds per row to clean, identify, re-organize, validate for duplicate entries, and write to a new table.  Essentially, 600 rows would take at least 30 minutes for the vba code to complete its task.  I have NEVER run into this issue before - Turning off Screen Updating has resolved any issues with speed I've had up until this point.

30 minutes just won't do.

So, I went hunting for solutions.  But, before I can solve the problem, I had to FIND the problem.

What is the problem?  Well, I found through the use of breakpoints where the lag in time was.  It was taking up to 3 seconds to simply place a batch of values that were stored in variables into empty cells. 

example line: 

Sheets("Converted").Cells(Rowc, 1).Value = Location

The issue was that Excel was recalculating the sheet every time a new value was placed in a cell.  So, how do we stop that? 

At the beginning of your vba code (probably right along with your line to deactivate screen updating) insert the following line:

Application.Calculation = xlCalculationManual

Then, at the bottom right before you end sub, insert the line:

Application.Calculation = xlCalculationAutomatic

BINGO!  Problem solved.