CODEWITHSUNDEEP
excelvba
Nick
Nick

Reputation: 687

Using CheckBox as autofilter buttons (excel VBA)

I am looking to use multiple (5) checkboxes to filter a single column in an excel table. The column to be filtered contains several markers namely 

 "","r","x","s","t"

Here a picture of the boxes:
enter image description here

My aim is to tick several boxes and include all the columns with said marker. Using straightforward methods results in the previous filter being cleared instead of being "added".

Here a picture of my (now two) tracking columns, one containing the identifier and another hidden converting that too the checkbox captions using ifs statements so @zac's solution works.enter image description here

I have a looked around a lot and found a thread on MrExcel where some code was provided however I was unable to adapt it to my exact needs. Sadly whichever button I press it keeps defaulting to the blank ("") marker.

Below is my code for a sub that should be called by each checkbox.

Background info:
The identifier value are defined in a table and assigned a dynamic named range "tracking" The column to be filtered is called ("Project Flag")
The code is contained in a seperate module 

Sub Project_Filter()
    Dim objcBox As Object
    Dim cBox As Variant
    Set Dbtbl = Sheets("Database").ListObjects("Entire")
    ReDim cBox(0)

    Dim trackers() As String
    Dim i As Integer
    Dim x As Variant

      i = -1
        For Each x In Range("Tracking").Cells 'reading named range into array
            i = i + 1
            ReDim Preserve trackers(i) As String
            trackers(i) = x.Value
        Next x

    Application.ScreenUpdating = False
    With Sheets("Database")
            For Each objcBox In .OLEObjects
                If TypeName(objcBox.Object) = "CheckBox" Then 'looking for checkboxes
                    If objcBox.Object.Value = True Then
                        cBox(UBound(cBox)) = trackers(i) 'setting cbox array as nth trackers value
                        i = i + 1
                        ReDim Preserve cBox(UBound(cBox) + 1)
                    End If
                End If
            Next
        If IsError(Application.Match((cBox), 0)) Then
            MsgBox "Nothing Selected"
            Exit Sub
        End If

        ReDim Preserve cBox(UBound(cBox))
        If Not .AutoFilterMode Then
            Dbtbl.Range.AutoFilter
            Dbtbl.Range.AutoFilter Field:=Dbtbl.HeaderRowRange.Find("Project Flag").Column, Criteria1:=Array(cBox)
        End If
    End With
    Application.ScreenUpdating = True
End Sub

So after some trial and error i found out that the array cbox() only contains the first value of my trackers array, hence it only filtering the blank entries. No idea what causes that but thought it might be noteworthy

Upvotes: 0

Views: 1355

Answers (1)

Zac
Zac

Reputation: 1942

Based on our conversation and the picture of your checkboxes in your description, we can get the filter text from the caption:

Option Explicit

Sub Project_Filter()

    Dim oOLE As Object
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet1")   ' <--- Remeber to change this
    Dim aFilter As Variant
    Dim sFilterChar As String

    ' Referenc the sheet
    With oWS

        ' If 'All Projects' checkbox is selected, unselect all other checkboxes
        If .OLEObjects("chkAll").Object.Value Then

            ClearCheckboxes

        End If

        ' Loop to capture all selected check boxes
        For Each oOLE In .OLEObjects

            If TypeName(oOLE.Object) = "CheckBox" And oOLE.Object.Value And oOLE.Object.Caption <> "All Projects" Then

                If Not IsArray(aFilter) Then
                    ReDim aFilter(0)
                Else
                    ReDim Preserve aFilter(UBound(aFilter) + 1)
                End If

                sFilterChar = Mid(oOLE.Object.Caption, 2, 1)
                If sFilterChar = "]" Then
                    aFilter(UBound(aFilter)) = ""
                Else
                    aFilter(UBound(aFilter)) = sFilterChar
                End If

            End If

        Next

        ' Set the filter based on selection
        If IsArray(aFilter) Then
            .ListObjects("Table1").Range.AutoFilter field:=2, Criteria1:=aFilter, Operator:=xlFilterValues
        Else
            .ListObjects("Table1").Range.AutoFilter
        End If

    End With

    ' Clear Object
    Set oWS = Nothing

End Sub

' Clear all checkboxes other than 'All Projects' checkbox
Private Sub ClearCheckboxes()

    Dim oOLE As Object
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet1")   ' <--- Remeber to change this

    With oWS

        ' Clear checkboxes
        For Each oOLE In .OLEObjects

            If TypeName(oOLE.Object) = "CheckBox" And oOLE.Object.Caption <> "All Projects" Then

                If oOLE.Object.Value Then
                    oOLE.Object.Value = False
                End If

            End If

        Next

    End With

    ' Clear object
    Set oWS = Nothing

End Sub

NOTE: I have All Projects as a checkbox as well

Upvotes: 1

Related Questions