PDA

View Full Version : [SOLVED] Toggle cell value on single click



zoom38
04-09-2015, 11:12 AM
Is it possible to change a cells value to either "X" or "" upon one click. I don't want to use the double click event. The code below will place an X in the cell upon one click but I cannot figure out how to empty the cell when clicked again. My code below will place an X in the cell regardless if it is empty or already has an X in it.



Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim myrange As Range
Set myrange = Range("M11:AC11,M15:X15,Z15,N19,Q19,T19,W19,Z19")
If Not Intersect(myrange, Target) Is Nothing Then 'Exit Sub
If Not IsEmpty(Target) Then
Target.Value = "X"
End If
End If
End Sub

If have searched the net and bulletin boards but have not found any code that would work for me.

Thanks
Gary

zoom38
04-09-2015, 11:45 AM
Please disregard, I was able to do it another way. This worked for me.



Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim myrange As Range
Set myrange = Range("M11:AC11,M15:X15,Z15,N19,Q19,T19,W19,Z19")

If Not Intersect(myrange, Target) Is Nothing Then
If ActiveCell.Value = "" Then
ActiveCell.Value = "X"
Else:
ActiveCell.Value = ""
End If
End If
End Sub

Gary

Paul_Hossler
04-09-2015, 11:53 AM
I think the DoubleClick is best, but two possible alternatives




Option Explicit
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim myrange As Range
Set myrange = Range("M11:AC11,M15:X15,Z15,N19,Q19,T19,W19,Z19")
If Intersect(myrange, Target) Is Nothing Then Exit Sub

Cancel = True

Application.EnableEvents = False
If IsEmpty(Target.Cells(1, 1)) Then
Target.Cells(1, 1).Value = "X"
Else
Target.Cells(1, 1).ClearContents
End If
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim myrange As Range
Set myrange = Range("M11:AC11,M15:X15,Z15,N19,Q19,T19,W19,Z19")
If Intersect(myrange, Target) Is Nothing Then Exit Sub

Application.EnableEvents = False
If IsEmpty(Target.Cells(1, 1)) Then
Target.Cells(1, 1).Value = "X"
Else
Target.Cells(1, 1).ClearContents
End If
Application.EnableEvents = True
End Sub

zoom38
04-09-2015, 01:55 PM
Unfortunately I'm not near my computer with Excel so I can't test it but looking at your two alternatives I like your second one best. I don't like the right click sub because it is not natural (assuming right click is the right mouse button). I've never used that one before. The one I worked out just before your post also seems to work out well. I'm marking it solved.

Many thanks again Paul

Gary

mperrah
04-09-2015, 02:53 PM
You can try this.
Start with the page font as arial
If the cell is blank, when clicked or arrowed into focus, a check mark is entered
then the focus is shifted 1 cell to the right using offset.
you can change the direction to above or below as you prefer:
(Offset(1) for down one. Offset(-1) for up one cell)
When clicked or arrowed into again, the check is removed.
The Marlett font letter "A" looks like a check mark...


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim Checkmark As Range

Set Checkmark = Range("M11:AC11,M15:X15,Z15,N19,Q19,T19,W19,Z19")

If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Checkmark) Is Nothing Then
With Target
If .Font.Name = "Arial" Then
.Font.Name = "Marlett"
.Value = "a"
.Offset(0, 1).Select
Else
If .Font.Name = "Marlett" And .Value = "a" Then
.ClearContents
.Font.Name = "Arial"
.Offset(0, 1).Select
End If
End If
End With
End If
End Sub



cheers
-mark

zoom38
04-13-2015, 06:02 AM
Mark, that is awesome, it does indeed look like checkmarks. I couldn't get your code to work right so I modified it to use Activecell.



Dim CheckMark As Range
Set CheckMark = Range("M11:AC11,M15:X15,Z15,N19,Q19,T19,W19,Z19")
If Not Intersect(CheckMark, Target) Is Nothing Then
If ActiveCell.Font.Name = "Arial" Then
ActiveCell.Font.Name = "Marlett"
ActiveCell.Value = "a"
Else:
ActiveCell.Font.Name = "Arial"
ActiveCell.Value = ""
End If
End If

Thank You
Gary

mperrah
04-13-2015, 06:45 AM
Great. Strange that mine didn't work but I'm glad my offer helped you