Replicating VBA code to several cells without adding it manually to each cell

nedwards902001

New member
Joined
Jul 17, 2017
Messages
6
Reaction score
0
Points
0
I have entered the following VBA code to simulate a checkbox since I cannot resize the actual checkbox using the checkbox control.



Private Sub Label1_Click()
If Label1.Caption = Chr(254) Then
Label1.Caption = Chr(168)
Else
Label1.Caption = Chr(254)
End If
End Sub
The problem is I need to know how to replicate the code to several cells without manually adding a VBA code in each cell.

Any help would be appreciated. Thank you.
 
You can use the double click event

Try something like this in the sheet module
Code:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim rng As Range
'build range of cells for the checkboxes
Set rng = Union(Range("B2:B10"), Range("E2:E10"), Range("K5"))

If Not Intersect(Target, rng) Is Nothing Then
    Cancel = True
    Call CheckBoxState
End If

End Sub


Private Sub CheckBoxState()

With ActiveCell
    .Font.Name = "Wingdings"
    .Font.Size = 16
    If .Value = Chr(254) Then
        .Value = Chr(168)
    Else
        .Value = Chr(254)
    End If
End With

End Sub
 
I'm sorry, I'm a little lost. I tried copying this code into the sheet module and was able to replicate the character set but not able to click to change from checked to unchecked. What am I doing wrong? Your code seems like I am definitely on the right path.. Thank you soooo much for responding and taking the time out of your day. I really appreciate it very much.
 
You need to double click the cell.

Sorry, I don't know how to do it with a single mouse click
 
No worries..now it makes sense! Okay I'm going to tinker with it a little and by golly I'm gonna get this working :) Thanks again for all your help. Have an awesome day!
 
YESSSS!!!!!

I figured it out. Thank you soooo much!

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rng As Range
'build range of cells for the checkboxes
Set rng = Range("A2:A50")

If Not Intersect(Target, rng) Is Nothing Then
Cancel = True
Call Label1_Click
End If

End Sub


Sub Label1_Click()
With ActiveCell
.Font.Name = "Wingdings"
.Font.Size = 16
If .Value = Chr(254) Then
.Value = Chr(168)
Else
.Value = Chr(254)
End If
End With

End Sub
 
Ned,

If you want to do it with a single click try this:

Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rng As Range
'build range of cells for the checkboxes
Set rng = Range("A2:A50")

If Not Intersect(Target, rng) Is Nothing Then
  Call Label1_Click
End If

End Sub

HTH :cool:
 
Or simply:

Code:
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  Dim rng As Range
  
  'Build range of cells for the checkboxes
  Set rng = Range("A2:A50")

  If Not Intersect(Target, rng) Is Nothing Then
  
    With Target
 
        .Font.Name = "Wingdings"
        .Font.Size = 16
        
        If .Value = Chr(254) Then
         .Value = Chr(168)
       Else
         .Value = Chr(254)
       End If
       
    End With

  End If

End Sub  'Worksheet_SelectionChange()

HTH :cool:
 
@ retired007geek
in case your suggestion is due to post #4
how do you know it's a click and not the tab, enter or arrow keys making the cell active ?
 
This works just as well! Thanks for the input..made it a bit easier. You guys are awesome..wish I had known about this site before.
 
Wow, didn't realize you could use the arrow keys to check and uncheck. Just tested this out...made my day! Thank you very much.
 
Back
Top