slicer - how to return records that have all slicer options selected?

[Dervos]

Dear Experts,

I am wondering if there is a way to set up a Slicer to return records ONLY if they have ALL slicer options selected? For example - I don't want to see records that have slicer options 1 OR 2 OR 3 etc. but records that have slicer options 1 AND 2 AND 3 etc. ?

Case Scenario:

Using Slicer, I have selected:

• Skillset - Coaching + Mentoring
• Score - 4

Records returned are for Coaching, Mentoring and combination of both.



What I am seeking to get is below - a combination of Coaching + Mentoring with a Score of 4.



Is that even possible?

Appreciate your help!
D

 

[Dervos]

anyone...?

 

[John_w]

This task is quite difficult because no event is triggered when the user clicks a slicer item, nor when the filtered table rows change. A workaround is to run a procedure every second using Application.OnTime, which checks the visible table rows and hides them if not all selected items for each slicer and column value match. See if this works for you.

Put this in the ThisWorkbook module:

Option Explicit

Private Sub Workbook_Open()
    StartTimer
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    StopTimer
End Sub

Put this in a new Class Module and rename it cRow:

Option Explicit

Public NameColA As String
Public Skillset_List As String
Public Score_List As String

Put this in a new Module:

Option Explicit

Public RunWhen As Double
Public Const cRunWhat = "Check_Slicers"
Public PrevSkillsetSelectedItems As String
Public PrevScoreSelectedItems As String

Public Sub StartTimer()
    RunWhen = Now + TimeSerial(0, 0, 1)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, Schedule:=True
End Sub

Public Sub StopTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, Schedule:=False
End Sub


Public Sub Check_Slicers()

    Dim slCache As SlicerCache
    Dim slItem As SlicerItem
    Dim SkillsetSelectedItems As String
    Dim ScoreSelectedItems As String
    
    'Restart the timer
    
    StartTimer
    DoEvents
    
    'Get list of selected items in Skillset slicer
    
    Set slCache = ThisWorkbook.SlicerCaches("Slicer_Skillset")
    SkillsetSelectedItems = ""
    For Each slItem In slCache.SlicerItems
        If slItem.Selected Then SkillsetSelectedItems = SkillsetSelectedItems & slItem.Value & ","
        DoEvents
    Next

    'Get list of selected items in Score slicer

    Set slCache = ThisWorkbook.SlicerCaches("Slicer_Score")
    ScoreSelectedItems = ""
    For Each slItem In slCache.SlicerItems
        If slItem.Selected Then ScoreSelectedItems = ScoreSelectedItems & slItem.Value & ","
        DoEvents
    Next

    'If either list has changed, check rows for possible hiding

    If SkillsetSelectedItems <> PrevSkillsetSelectedItems Or _
       ScoreSelectedItems <> PrevScoreSelectedItems Then
    
        Check_and_Hide_Rows
        
    End If

    PrevSkillsetSelectedItems = SkillsetSelectedItems
    PrevScoreSelectedItems = ScoreSelectedItems
    
End Sub


Public Sub Check_and_Hide_Rows()

    Static VisibleNamesDict As Object 'Dictionary
    Dim table As ListObject
    Dim visibleAreas As Areas
    Dim areaRange As Range
    Dim r As Long
    Dim thisRow As cRow
    Dim SkillsetSC As SlicerCache
    Dim ScoreSC As SlicerCache
    Dim slItem As SlicerItem
    Dim FoundSkillsetCount As Long, FoundScoreCount As Long
    Dim SkillsetSlicerCount As Long, ScoreSlicerCount As Long
        
    Set SkillsetSC = ThisWorkbook.SlicerCaches("Slicer_Skillset")
    Set ScoreSC = ThisWorkbook.SlicerCaches("Slicer_Score")
    Set table = SkillsetSC.ListObject
    
    SkillsetSC.ListObject.AutoFilter.ApplyFilter
    ScoreSC.ListObject.AutoFilter.ApplyFilter
    
    If VisibleNamesDict Is Nothing Then
        Set VisibleNamesDict = CreateObject("Scripting.Dictionary")
    Else
        VisibleNamesDict.RemoveAll
    End If
        
    Set visibleAreas = Nothing
    On Error Resume Next
    Set visibleAreas = table.DataBodyRange.SpecialCells(xlCellTypeVisible).Areas
    On Error GoTo 0
    
    If Not visibleAreas Is Nothing Then

        'Create VisibleNamesDict dictionary with 1 entry for each unique visible name

        For Each areaRange In visibleAreas
            
            For r = 1 To areaRange.Rows.Count
                
                Set thisRow = New cRow
                thisRow.NameColA = areaRange.Item(r, 1).Value
                If Not VisibleNamesDict.Exists(thisRow.NameColA) Then
                    thisRow.Skillset_List = areaRange.Item(r, 2).Value & ","
                    thisRow.Score_List = areaRange.Item(r, 3).Value & ","
                    VisibleNamesDict.Add thisRow.NameColA, thisRow
                Else
                    Set thisRow = VisibleNamesDict(thisRow.NameColA)
                    thisRow.Skillset_List = thisRow.Skillset_List & areaRange.Item(r, 2).Value & ","
                    thisRow.Score_List = thisRow.Score_List & areaRange.Item(r, 3).Value & ","
                End If
                
                DoEvents
            
            Next
            
        Next
    
        'Check if each row should be hidden, depending on whether selected items in Skillset and Score slicers are found in Skillset list and Score list
        'for each visible name
        
        Application.ScreenUpdating = False
        
        For Each areaRange In visibleAreas
            
            For r = 1 To areaRange.Rows.Count
            
                Set thisRow = VisibleNamesDict(areaRange.Item(r, 1).Value)
                
                FoundSkillsetCount = 0
                SkillsetSlicerCount = 0
                For Each slItem In SkillsetSC.SlicerItems
                    If slItem.Selected Then
                        SkillsetSlicerCount = SkillsetSlicerCount + 1
                        If InStr("," & thisRow.Skillset_List, "," & slItem.Value & ",") Then FoundSkillsetCount = FoundSkillsetCount + 1
                    End If
                    DoEvents
                Next
                
                FoundScoreCount = 0
                ScoreSlicerCount = 0
                For Each slItem In ScoreSC.SlicerItems
                    If slItem.Selected Then
                        ScoreSlicerCount = ScoreSlicerCount + 1
                        If InStr("," & thisRow.Score_List, "," & slItem.Value & ",") Then FoundScoreCount = FoundScoreCount + 1
                    End If
                    DoEvents
                Next
                
                If FoundSkillsetCount <> SkillsetSlicerCount Or FoundScoreCount <> ScoreSlicerCount Then
                
                    'Hide row because Skillset list for this Name is not the same as the selected Skillset slicer items,
                    'or the Score list for this Name is not the same as the selected Score slicer items
                    
                    areaRange.Item(r, 1).EntireRow.Hidden = True
                    DoEvents
                    
                End If
                
            Next
            
        Next
    
        Application.ScreenUpdating = True
    
    End If

End Sub

Save the workbook as a .xlsm or .xlsb file, close and reopen it. It my tests with 20 rows of data it seems to work OK.

 

[Dervos]

Hi John,

Big Thanks for the reply!

Unfortunately the rows are not being refreshed after inputting the code, though I can see my mouse icon blinking.

Can this be happening due to the fact that my table is part of a power query?

Once again - I appreciate your help!

 

[John_w]

Without knowing the exact details of your source data and how you are importing it (via the Power Query) it will be difficult to help you, so you'll need to do some debugging and investigation.

My test data was just a table of 20 rows in a single worksheet with the slicers on the same worksheet. I created a workbook with just the table and imported that via a Power Query into a 2nd worksheet in the macro workbook (still imported as a table), added the 2 slicers and all I had to do to make the code work was change the name of slicers from Slicer_Skillset to Slicer_Skillset1 and Slicer_Score to Slicer_Score1.

The part of the code which checks the rows and decides which ones should be hidden is inside this If statement:

    If Not visibleAreas Is Nothing Then

so if that statement isn't True nothing will be hidden. Debug the code by adding the following statement after the Set table line:

    Debug.Print table.Name, table.DataBodyRange.Address, table.Parent.Name

This displays the table name, table data address and parent sheet name in the Immediate Window. Set a breakpoint on that line, run StopTimer followed by StartTimer, click one of the slicers, to run to the breakpoint, then execute that line and make sure the details are correct.

 

[Dervos]

Hi John,

I've tested it on a fresh sheet with 20 rows and it works without any hassle!

However my data set is over 12k rows... After amending the slicer titles in vba - filtering has successfully started but crashed my excel after a few secs

Having 12k+ rows in mind - is there a way to solve the crashing issue?

Thanks again!

 

[John_w]

With 12k rows the Check_and_Hide_Rows routine will be slow to finish, so having an OnTime procedure which gives the appearance of reacting in real time to the user clicking slicer items is not going to work very well. Therefore I suggest forgetting about OnTime (delete the code in ThisWorkbook) and run Check_and_Hide_Rows manually from a button click, or the macros menu. There are 1 or 2 tweaks which can be made to speed up the macro, but it will still be quite slow because it has to loop through the visible areas and I can't think of a way to avoid this.

 

[Dervos]

The macro solution does work for me - so i am happy with the outcome.

Huge thanks for your input!

Regards,
D

 

[John_w]

Excellent - thanks for the feedback!

This revised version should be slightly faster because it puts the selected items for the 2 slicers in 2 arrays, and puts each area range in an array. It also displays the number of visible rows at the end. Note it also uses the Trim function because my data has trailing spaces and Excel automatically removes leading and trailing spaces from slicer item values, but you can remove the Trims if your data doesn't have leading or trailing spaces. Just change the SlicerCaches names to your names and the macro should work for you.

Public Sub Check_and_Hide_Rows2()

    Dim VisibleNamesDict As Object 'Dictionary
    Dim table As ListObject
    Dim visibleAreas As Areas
    Dim areaRange As Range
    Dim thisAreaRange As Variant
    Dim r As Long, i As Long
    Dim thisRow As cRow
    Dim Slicer1SC As SlicerCache
    Dim Slicer2SC As SlicerCache
    Dim slItem As SlicerItem
    Dim FoundSlicer1Count As Long, FoundSlicer2Count As Long
    Dim Slicer1Count As Long, Slicer2Count As Long
    Dim numRows As Long
    Dim Slicer1SelectedItems() As String, numSlicer1SelectedItems As Long
    Dim Slicer2SelectedItems() As String, numSlicer2SelectedItems As Long
    
    Set Slicer1SC = ThisWorkbook.SlicerCaches("Slicer_Skillset")   'CHANGE THIS SLICER NAME
    Set Slicer2SC = ThisWorkbook.SlicerCaches("Slicer_Score")     'CHANGE THIS SLICER NAME
    Set table = Slicer1SC.ListObject
    
    Slicer1SC.ListObject.AutoFilter.ApplyFilter
    Slicer2SC.ListObject.AutoFilter.ApplyFilter
    
    'Set VisibleNamesDict = New Dictionary
    Set VisibleNamesDict = CreateObject("Scripting.Dictionary")
   
    Set visibleAreas = Nothing
    On Error Resume Next
    Set visibleAreas = table.DataBodyRange.SpecialCells(xlCellTypeVisible).Areas
    On Error GoTo 0
    
    If Not visibleAreas Is Nothing Then
    
        'Create VisibleNamesDict dictionary with 1 entry for each unique visible name
    
        For Each areaRange In visibleAreas
            thisAreaRange = areaRange.Value            
            For r = 1 To UBound(thisAreaRange)                
                Set thisRow = New cRow
                thisRow.NameColA = thisAreaRange(r, 1)
                If Not VisibleNamesDict.Exists(thisRow.NameColA) Then
                    thisRow.Slicer1Col_List = Trim(thisAreaRange(r, 2)) & ","
                    thisRow.Slicer2Col_List = Trim(thisAreaRange(r, 3)) & ","
                    VisibleNamesDict.Add thisRow.NameColA, thisRow
                Else
                    Set thisRow = VisibleNamesDict(thisRow.NameColA)
                    If InStr(1, "," & thisRow.Slicer1Col_List, "," & Trim(thisAreaRange(r, 2)) & ",") = 0 Then
                        thisRow.Slicer1Col_List = thisRow.Slicer1Col_List & Trim(thisAreaRange(r, 2)) & ","
                    End If
                    If InStr(1, "," & thisRow.Slicer2Col_List, "," & Trim(thisAreaRange(r, 3)) & ",") = 0 Then
                        thisRow.Slicer2Col_List = thisRow.Slicer2Col_List & Trim(thisAreaRange(r, 3)) & ","
                    End If
                End If
            Next            
        Next
    
        'Create arrays of selected items in Slicer1 and Slicer2
        
        numSlicer1SelectedItems = 0
        For Each slItem In Slicer1SC.SlicerItems
            If slItem.Selected Then
                numSlicer1SelectedItems = numSlicer1SelectedItems + 1
                ReDim Preserve Slicer1SelectedItems(1 To numSlicer1SelectedItems)
                Slicer1SelectedItems(numSlicer1SelectedItems) = slItem.Value
            End If
        Next
        
        numSlicer2SelectedItems = 0
        For Each slItem In Slicer2SC.SlicerItems
            If slItem.Selected Then
                numSlicer2SelectedItems = numSlicer2SelectedItems + 1
                ReDim Preserve Slicer2SelectedItems(1 To numSlicer2SelectedItems)
                Slicer2SelectedItems(numSlicer2SelectedItems) = slItem.Value
            End If
        Next
        
        'Check if each row should be hidden, depending on whether selected items in Slicer1 and Slicer2 are found in Slicer1Col_List and Slicer2Col_List
        'for each visible name
        
        Application.ScreenUpdating = False
        
        For Each areaRange In visibleAreas
            thisAreaRange = areaRange.Value
            
            For r = 1 To UBound(thisAreaRange)
            
                Set thisRow = VisibleNamesDict(thisAreaRange(r, 1))
                
                FoundSlicer1Count = 0
                For i = 1 To UBound(Slicer1SelectedItems)
                    If InStr("," & thisRow.Slicer1Col_List, "," & Slicer1SelectedItems(i) & ",") Then FoundSlicer1Count = FoundSlicer1Count + 1
                Next
                
                FoundSlicer2Count = 0
                For i = 1 To UBound(Slicer2SelectedItems)
                    If InStr("," & thisRow.Slicer2Col_List, "," & Slicer2SelectedItems(i) & ",") Then FoundSlicer2Count = FoundSlicer2Count + 1
                Next
                
                If FoundSlicer1Count <> numSlicer1SelectedItems Or FoundSlicer2Count <> numSlicer2SelectedItems Then
                
                    'Hide row because Slicer1Col_List for this Col A value is not the same as the selected Slicer1 slicer items,
                    'or the Slicer2Col_List for this Col A value is not the same as the selected Slicer2 slicer items
                    
                    areaRange.Item(r, 1).EntireRow.Hidden = True
                
                End If
                
            Next
            
            DoEvents
            
        Next
        
        Application.ScreenUpdating = True
    
    End If
   
    Set visibleAreas = Nothing
    On Error Resume Next
    Set visibleAreas = table.DataBodyRange.SpecialCells(xlCellTypeVisible).Areas
    On Error GoTo 0
    
    numRows = 0
    
    If Not visibleAreas Is Nothing Then
    
        'Count number of visible rows
    
        For Each areaRange In visibleAreas
            numRows = numRows + areaRange.Rows.Count
        Next
        
    End If
       
    Application.StatusBar = numRows & " matching rows found in " & table.DataBodyRange.Rows.Count & " rows"

End Sub

I also changed class module cRow:

Option Explicit

Public NameColA As String
Public Slicer1Col_List As String
Public Slicer2Col_List As String

 

[Dervos]

brilliant - this does make things quicker!

one more question though - if i was to select multiple skillsets AND multiple scores i.e. 3 + 4 (or other combinations i.e. 3 + 1 / 2 + 3 etc) - is it also possible to return records with score values of 4&4 and 3&4?

i.e. slicer selection is:

• Skillset - Coaching + Mentoring
• Score - 4 + 3

results after running script with the above slicer selection - returns only combination of both scores:



ideal result after running script - returns records with score combinations of 4 & 4 , 4 & 3 , 3 & 4.