CheckedRange Class
up vote
2
down vote
favorite
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.
vba excel
add a comment |
up vote
2
down vote
favorite
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.
vba excel
add a comment |
up vote
2
down vote
favorite
up vote
2
down vote
favorite
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.
vba excel
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.
vba excel
vba excel
asked 13 hours ago
TinMan
87318
87318
add a comment |
add a comment |
active
oldest
votes
active
oldest
votes
active
oldest
votes
active
oldest
votes
active
oldest
votes
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fcodereview.stackexchange.com%2fquestions%2f207698%2fcheckedrange-class%23new-answer', 'question_page');
}
);
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown