Class module for checkboxes

figment222

New Member
Joined
Mar 6, 2015
Messages
48
I have a class module set to encompass ALL checkboxes on sheet, so that when any of them are clicked, a sub will run to populate some cells. It works great, but I'm having some trouble because I still want to group some of the cells together to create a user form. I'll have tons of checkboxes and aside from being able to move and position them in groups, some of them might also need to run a separate sub, because they relate to a different range on my sheet.

The code runs fine when the checkboxes are individual, but if I group them together, I get an error box:

"run-time error '438: Object doesn't support this property or method"

The code seems to be fine again, once I ungroup the checkboxes. I hope I don't have to try and move these things around individually as the form begins to take shape.

My question is: How can I group checkboxes together without getting a runtime error?

Here's the code I have: Class module called: ChkClass

Option Explicit

Public WithEvents ChkBoxGroup As MSForms.CheckBox

Private Sub ChkBoxGroup_Change()
Debug.Print "ChkBoxGroup_Change"
End Sub

Private Sub ChkBoxGroup_Click()
Dim findrow As Long, findrow2 As Long, i As Long
findrow = Range("B:B").Find("Feature Styles", Range("B1")).Row
findrow2 = Range("B:B").Find("Feature Options", Range("B" & findrow)).Row
For i = findrow To findrow2

If Range("B" & i).Value = Range("O" & i).Value Then
Range("C" & i).Value = True
Else: Range("C" & i).Value = False
End If
Next i
End Sub
I also have in module1:

Option Explicit

Dim CheckBoxes() As New ChkClass
Const numChkBoxes = 20
'

Sub doCheckBoxes()
makeCheckBoxes
activateCheckBoxes
End Sub

Sub makeCheckBoxes() ' creates a column of checkBoxes

Dim sht As Worksheet
Set sht = ActiveSheet

Dim i As Integer
For i = 1 To sht.Shapes.Count
' Debug.Print sht.Shapes(1).Properties
sht.Shapes(1).Delete
DoEvents
Next i

Dim xSize As Integer: xSize = 2 ' horizontal size (number of cells)
Dim ySize As Integer: ySize = 1 ' vertical size

Dim t As Range
Set t = sht.Range("g2").Resize(ySize, xSize)

For i = 1 To numChkBoxes
sht.Shapes.AddOLEObject ClassType:="Forms.CheckBox.1", Left:=t.Left,
Top:=t.Top, Width:=t.Width - 2, Height:=t.Height
DoEvents
Set t = t.Offset(ySize)
Next i

End Sub

Sub activateCheckBoxes() ' assigns all checkBoxes on worksheet to
ChkClass.ChkBoxGroup

Dim sht As Worksheet
Set sht = ActiveSheet

ReDim CheckBoxes(1 To 1)

Dim i As Integer
For i = 1 To sht.Shapes.Count

ReDim Preserve CheckBoxes(1 To i)
Set CheckBoxes(i).ChkBoxGroup = sht.Shapes(i).OLEFormat.Object.Object

Next i

End Sub
Finally, in the main sheet module:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
activateCheckBoxes
End Sub
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.

Forum statistics

Threads
1,214,589
Messages
6,120,416
Members
448,960
Latest member
AKSMITH

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top