Krdytkyu

This class is used to make Excel Cells behave like Checkboxes. Clicking the cell raises a CheckedRange_Clicked(Target as Range) event and toggles it's value between 0 and -1. A combination of Fonts and Custom NumberFormats display the cell values as Checkboxes, Checkmarks, Yes/No, True/False or a custom format.

Class: CheckedRange

Attribute VB_Name = "CheckedRange"

Attribute VB_PredeclaredId = True

Option Explicit

Public Enum WingdingsCharCode

    CheckBoxChecked = 254

    CheckBoxUnchecked = 168

    XMark = 251

    CheckMark = 252

End Enum



Public Enum CheckedRangeTheme

    ctCheckBoxes

    ctCheckmarks

    ctTrueFalse

    ctYesNo

End Enum



Private Type Members

    CheckedCode As Long

    CheckedColor As String

    CheckedString As String

    EditMode As Boolean

    FontName As String

    PrevAddress As String

    RangeFormula As String

    Theme As CheckedRangeTheme

    TrueFalse As Boolean

    UnCheckedCode As Long

    UnCheckedColor As String

    UnCheckedString As String

    YesNo As Boolean

End Type

Private this As Members



Public Event Clicked(Target As Range)

Public WithEvents Worksheet As Worksheet

Attribute Worksheet.VB_VarHelpID = -1



Private m_bUseYesNo As Boolean



Private m_sCheckedString As String

Private m_sUnCheckedString As String



Private m_bEditMode As Boolean



Private Sub Class_Initialize()

    EditMode = True

    Me.Theme = CheckedRangeTheme.ctCheckBoxes

    EditMode = False

End Sub



Public Property Get CheckedCode() As WingdingsCharCode

    CheckedCode = this.CheckedCode

End Property



Public Property Let CheckedCode(ByVal Value As WingdingsCharCode)

    CheckedString = Chr(Value)

    this.CheckedCode = Value

End Property



Public Property Get CheckedColor() As String

    CheckedColor = this.CheckedColor

End Property



Public Property Let CheckedColor(ByVal Value As String)

    this.CheckedColor = Value

End Property



Public Property Get CheckedString() As String

    CheckedString = this.CheckedString

End Property



Public Property Let CheckedString(ByVal Value As String)

    this.CheckedString = Value

End Property



Public Property Get FontName() As String

    FontName = this.FontName

End Property



Public Property Let FontName(ByVal Value As String)

    this.FontName = Value

End Property



Public Property Get NumberFormat() As String

    Dim CheckedColor As String, UnCheckedColor As String

    CheckedColor = IIf(Len(this.CheckedColor) > 0, "[" & this.CheckedColor & "]", "")

    UnCheckedColor = IIf(Len(this.UnCheckedColor) > 0, "[" & this.UnCheckedColor & "]", "")



    NumberFormat = ";" & CheckedColor & Chr(34) & this.CheckedString & Chr(34) & _

                   ";" & UnCheckedColor & Chr(34) & this.UnCheckedString & Chr(34)



End Property



Public Property Get RangeFormula() As String

    RangeFormula = this.RangeFormula

End Property



Public Property Let RangeFormula(ByVal Value As String)

    this.RangeFormula = Value

End Property



Public Property Get Self() As CheckedRange

    Set Self = Me

End Property



Public Property Get Theme() As CheckedRangeTheme

    Theme = this.Theme

End Property



Public Property Let Theme(ByVal Value As CheckedRangeTheme)

    this.Theme = Value

    Select Case this.Theme

        Case CheckedRangeTheme.ctCheckBoxes

            this.FontName = "Wingdings"

            CheckedCode = WingdingsCharCode.CheckBoxChecked

            UnCheckedCode = WingdingsCharCode.CheckBoxUnchecked

        Case CheckedRangeTheme.ctCheckmarks

            this.FontName = "Wingdings"

            CheckedCode = WingdingsCharCode.CheckMark

            UnCheckedCode = WingdingsCharCode.XMark

        Case CheckedRangeTheme.ctTrueFalse

            TrueFalse = True

        Case CheckedRangeTheme.ctYesNo

            YesNo = True

    End Select

    Me.Apply

End Property



Public Property Get TrueFalse() As Boolean

    TrueFalse = this.TrueFalse

End Property



Public Property Let TrueFalse(ByVal Value As Boolean)

    CheckedString = "True"

    UnCheckedString = "False"

    Me.FontName = "Calibri"

    this.TrueFalse = Value

    Me.Apply

End Property



Public Property Get UnCheckedCode() As WingdingsCharCode

    UnCheckedCode = this.UnCheckedCode

End Property



Public Property Let UnCheckedCode(ByVal Value As WingdingsCharCode)

    UnCheckedString = Chr(Value)

    this.UnCheckedCode = Value

    Me.Apply

End Property



Public Property Get UnCheckedColor() As String

    UnCheckedColor = this.UnCheckedColor

End Property



Public Property Let UnCheckedColor(ByVal Value As String)

    this.UnCheckedColor = Value

    Me.Apply

End Property



Public Property Get UnCheckedString() As String

    UnCheckedString = this.UnCheckedString

End Property



Public Property Let UnCheckedString(ByVal Value As String)

    this.UnCheckedString = Value

    Me.Apply

End Property



Public Property Let YesNo(ByVal Value As Boolean)

    CheckedString = "Yes"

    UnCheckedString = "No"

    Me.FontName = "Calibri"

    this.YesNo = Value

    Me.Apply

End Property



Public Property Get YesNo() As Boolean

    YesNo = this.YesNo

End Property



Public Function Create(TargetWorksheet As Worksheet, RangeFormula As String, Optional Theme As CheckedRangeTheme = CheckedRangeTheme.ctCheckBoxes) As CheckedRange

    With New CheckedRange

        .EditMode = True

        .Theme = Theme

        .RangeFormula = RangeFormula

        Set .Worksheet = TargetWorksheet

        .EditMode = False

        .Apply

        Set Create = .Self

    End With

End Function



Public Property Get EditMode() As Boolean

    EditMode = this.EditMode

End Property



Public Property Let EditMode(ByVal Value As Boolean)

    this.EditMode = Value

End Property



Public Sub Apply()

    If Me.EditMode Then Exit Sub

    Dim Target As Range

    Set Target = Me.Range



    If Target Is Nothing Then Exit Sub



    this.PrevAddress = Target.Address



    With Target

        .Font.Name = FontName

        .NumberFormat = NumberFormat

        If .Count = 1 Then

            If Len(.Value) = 0 Or .Value = 0 Then

                .Value = 0

            Else

                .Value = -1

            End If

        Else

            Dim result() As Variant

            result = .Value

            Dim r As Long, c As Long



            For r = 1 To UBound(result)

                For c = 1 To UBound(result, 2)

                    If Len(result(r, c)) = 0 Or result(r, c) = 0 Then

                        result(r, c) = 0

                    Else

                        result(r, c) = -1

                    End If

                Next

            Next

            .Value = result

        End If

    End With

End Sub



Public Property Get Range() As Range

    On Error Resume Next

    Set Range = Worksheet.Range(this.RangeFormula)

End Property



Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim MyRange As Range

    Set MyRange = Me.Range



    If MyRange Is Nothing Then Exit Sub



    If Not Intersect(Target, MyRange) Is Nothing Then

        Cancel = True

    End If

End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim MyRange As Range

    Set MyRange = Me.Range



    If MyRange Is Nothing Then Exit Sub

    If Target.CountLarge > 1 Then Exit Sub



    If Not Intersect(Target, MyRange) Is Nothing Then

        Application.EnableEvents = False

        Target.Value = IIf(Target.Value = -1, 0, -1)

        Application.EnableEvents = True

        RaiseEvent Clicked(Target)

    End If



    If MyRange.Address <> this.PrevAddress Then Me.Apply



End Sub

Worksheet Module Test Code

Option Explicit

Private WithEvents CheckedRange1 As CheckedRange

Private WithEvents CheckedRange2 As CheckedRange

Private WithEvents CheckedRange3 As CheckedRange

Private WithEvents CheckedRange4 As CheckedRange

Private WithEvents CheckedRange5 As CheckedRange



Private Sub Worksheet_Activate()

    Set CheckedRange1 = CheckedRange.Create(Me, "OFFSET(G1,1,-6,COUNTA(G:G)-1,1)")

    Set CheckedRange2 = CheckedRange.Create(Me, "OFFSET(G1,1,-5,COUNTA(G:G)-1,1)", CheckedRangeTheme.ctCheckmarks)

    Set CheckedRange3 = CheckedRange.Create(Me, "OFFSET(G1,1,-4,COUNTA(G:G)-1,1)", CheckedRangeTheme.ctTrueFalse)

    Set CheckedRange4 = CheckedRange.Create(Me, "OFFSET(G1,1,-3,COUNTA(G:G)-1,1)", CheckedRangeTheme.ctYesNo)

    Set CheckedRange5 = CheckedRange.Create(Me, "OFFSET(G1,1,-2,COUNTA(G:G)-1,2)")

    With CheckedRange5

        .EditMode = True

        .CheckedCode = 253

        .UnCheckedCode = 168

        .CheckedColor = "Blue"

        .UnCheckedColor = "Magenta"

        .EditMode = False

        .Apply

    End With

End Sub



Private Sub CheckedRange1_Clicked(Target As Range)

    setLabelCaption "CheckedRange1", Target

End Sub



Private Sub CheckedRange2_Clicked(Target As Range)

    setLabelCaption "CheckedRange2", Target

End Sub



Private Sub CheckedRange3_Clicked(Target As Range)

    setLabelCaption "CheckedRange3", Target

End Sub



Private Sub CheckedRange4_Clicked(Target As Range)

    setLabelCaption "CheckedRange4", Target

End Sub



Private Sub CheckedRange5_Clicked(Target As Range)

    setLabelCaption "CheckedRange5", Target

End Sub



Private Sub setLabelCaption(CheckedRangeName As String, Target As Range)

    Me.Label1.Caption = CheckedRangeName & ": Clicked" & vbNewLine & _

                        "Range: " & Target.Address & vbNewLine & _

                        "Value: " & Target.Value

End Sub

I'm disappointed that the range filter does not use the same font as range causing symbols that require special fonts to display improperly(e.g. Chr(254) displays as in the cells using Wingdings but þ in the Filter). I don't think that there is a reasonable way to fix this but I am open to suggestions.