Click on a cell and have check mark displayed in MS Excel

[ogopogo5]

I would like to be able to click on a cell and have a check mark
displayed in a cell. Then click on the cell again to disappear. Also
indicate what cell range will display the check mark.

Thank you in advance.



*** Sent via Developersdex http://www.developersdex.com ***

 

[OssieMac]

Needs to be a Double click so that it will fire an event on Double Click.
Can't do it on single click.

Copy the following code into the Sheet module in the VBA editor. If you need
instructions to do this then get back to me.

Edit the range "A1:G10" to the range that you want to use for the
check marks to be inserted/deleted.

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

Dim isect As Object

'Test if target in required range
Set isect = Application.Intersect(Target, Range("A1:G10"))

If Not isect Is Nothing Then
'Cancel Edit mode invoked by double click
Cancel = True

'Test if cell already contains check mark
If ActiveCell = Chr(252) Then
'Clear check mark
ActiveCell.ClearContents
Else
'Insert check mark code
ActiveCell = Chr(252)
'Change font to Wingdings
With ActiveCell.Characters _
(Start:=1, Length:=1).Font

.Name = "Wingdings"

End With
End If
End If

End Sub

 

[OssieMac]

My apologies. My comment "Can't do it on single click" is not correct. You
could use the following and it will place/remove a check mark on a cell when
the cell is selected. However, it doesn't matter whether selected by clicking
on the cell or using the arrow keys to select. I think that double click
method is better but here is the code to simply click if you want it. Place
it in the Sheet module.

Note that the sub names in both of my replies are critical. You can't use a
different sub name or place the following code in the Double click sub.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim isect As Object

'Test if target in required range
Set isect = Application.Intersect(Target, Range("A1:G10"))

If Not isect Is Nothing Then

'Test if cell already contains check mark
If ActiveCell = Chr(252) Then
'Clear check mark
ActiveCell.ClearContents
Else
'Insert check mark code
ActiveCell = Chr(252)
'Change font to Wingdings
With ActiveCell.Characters _
(Start:=1, Length:=1).Font

.Name = "Wingdings"

End With
End If
End If

End Sub