3
\$\begingroup\$

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.

CheckedRange Demo

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 checkbox 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.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.