Click Cell to toggle color

[chuckchuckit]

Here is code to color/uncolor a cell you click. It does not toggle unless you click a different cell first, then come back and click original cell again.

How can I get it to toggle color on/off while remaining in same cell?

Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    Dim cRED, cGREEN
    cRED = 255
    cGREEN = 5296274
    If Intersect(Target, Range("B2:G10")) Is Nothing Then Exit Sub
 
        'Click and drag in range causes run time error
        'so capture error and exit sub instead
    On Error GoTo errTrap
 
    Application.EnableEvents = False
 
        'Toggle background color on or off
    If ActiveCell.Interior.Pattern = xlSolid Then
            'erase background to no color
        With Selection.Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    Else 'no color so make it a backround color
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = cGREEN
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End If
 
    Application.EnableEvents = True
 
errTrap:     'code goes here if error clicking and dragging
    Exit Sub
End Sub

 

[chuckchuckit]

Thanks again everyone. This Excel forum is amazing. People like myself can really get stuck sometimes coding, and the assistance here make things a lot easier. It is appreciated. - Chuck

 

[chuckchuckit]

I finanlized a version using pieces from many that helped here. Thanks to you all.

The code now uses right click to change background color, keep clicking to change to different color. Works well for what I needed.

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'
'To highlight a cell with a background color, right click on a cell in range
'Keep right clicking to change to desired color.
 
    Dim cLightGREEN, cMediumGREEN, cBrightGREEN, cDullGREEN, cDullYELLOW, cBrightYELLOW, cDullRED, cBrightRED
 
    cBrightGREEN = 65280
    cDullGREEN = 5296274
    cDullYELLOW = 6750207
    cDullRED = 8420607
        'Colors not currently used
    cLightGREEN = 10092492
    cMediumGREEN = 3407820
    cBrightYELLOW = 65535
    cBrightRED = 255
 
    If Intersect(Target, Range("B2:G10")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Cancel = True 'disable the right click menus so they do not pop up in range
 
        'Is cell blank background, no fill
    If ActiveCell.Interior.Pattern = xlNone Then
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = cBrightGREEN
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
 
    ElseIf Selection.Interior.Color = cBrightGREEN Then
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = cDullGREEN
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
 
    ElseIf Selection.Interior.Color = cDullGREEN Then
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = cDullYELLOW
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
 
    ElseIf Selection.Interior.Color = cDullYELLOW Then
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = cDullRED
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
 
    ElseIf Selection.Interior.Color = cDullRED Then
        With Selection.Interior
            .Pattern = xlNone 'BLANK, NO FILL
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
 
    Else 'if not any of our colors, and is not blank, make it top color
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = cBrightGREEN
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
 
    End If
 
    Application.EnableEvents = True
 
End Sub

 

[dave3009]

You could condense that into a Select Case statement

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'
'To highlight a cell with a background color, right click on a cell in range
'Keep right clicking to change to desired color.
 
    Dim cLightGREEN, cMediumGREEN, cBrightGREEN, cDullGREEN, cDullYELLOW, cBrightYELLOW, cDullRED, cBrightRED
 
    cBrightGREEN = 65280
    cDullGREEN = 5296274
    cDullYELLOW = 6750207
    cDullRED = 8420607
        'Colors not currently used
    cLightGREEN = 10092492
    cMediumGREEN = 3407820
    cBrightYELLOW = 65535
    cBrightRED = 255
 
    If Intersect(Target, Range("B2:G10")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Cancel = True 'disable the right click menus so they do not pop up in range
 
        'Is cell blank background, no fill
        With Target.Interior
        Select Case .Color
            Case xlNone: .Color = cBrightGREEN
            Case cBrightGREEN: .Color = cDullGREEN
            Case cDullGREEN: .Color = cDullYELLOW
            Case cDullYELLOW: .Color = cDullRED
            Case cDullRED: .Pattern = xlNone  'BLANK, NO FILL
            Case Else: .Color = cBrightGREEN
        End Select
    End With
    Application.EnableEvents = True
 
End Sub

 

[chuckchuckit]

Yes, that is much more condensed and works well. Think I'll change my code to use the case's instead.

I am wondering how to get an other cell (10 columns to the right) to mirror those color changes. Meaning if I right click cell B2 and it changes to cBrightGREEN, how could I get the same thing to happen 10 columns over to cell M2?

But not format cell M2 with a formula, but rather have it part of the case code that would change cell B2 and cell M2 together.

 

[dave3009]

Like this perhaps

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'
'To highlight a cell with a background color, right click on a cell in range
'Keep right clicking to change to desired color.
 
    Dim cLightGREEN, cMediumGREEN, cBrightGREEN, cDullGREEN, cDullYELLOW, cBrightYELLOW, cDullRED, cBrightRED
 
    cBrightGREEN = 65280
    cDullGREEN = 5296274
    cDullYELLOW = 6750207
    cDullRED = 8420607
        'Colors not currently used
    cLightGREEN = 10092492
    cMediumGREEN = 3407820
    cBrightYELLOW = 65535
    cBrightRED = 255
 
    If Intersect(Target, Range("B2:G10")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Cancel = True 'disable the right click menus so they do not pop up in range
 
        'Is cell blank background, no fill
        With Target.Interior
        Select Case .Color
            Case xlNone: .Color = cBrightGREEN
                            Target.Offset(0, 11).Interior.Color = cBrightGREEN
            Case cBrightGREEN: .Color = cDullGREEN
                            Target.Offset(0, 11).Interior.Color = cDullGREEN
            Case cDullGREEN: .Color = cDullYELLOW
                            Target.Offset(0, 11).Interior.Color = cDullYELLOW
            Case cDullYELLOW: .Color = cDullRED
                            Target.Offset(0, 11).Interior.Color = cDullRED
            Case cDullRED: .Color = xlNone  'BLANK, NO FILL
                            Target.Offset(0, 11).Interior.Color = xlNone
            Case Else: .Color = cBrightGREEN
                            Target.Offset(0, 11).Interior.Color = cBrightGREEN
        End Select
    End With
    Application.EnableEvents = True
 
End Sub

 

[chuckchuckit]

Wow, that did it. Works like a champ. Nice code.

Thanks.

 

[chuckchuckit]

Right clicking fast has a delay when cycling through the color changes. Code below with new changes fixes that.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
If you right click faster than once per second the color does not change. Coloring many cells differently can then be time consuming as you have to click slowly to cycle through the colors to get the one you want for each cell.
<o></o>
I tried removing the double click feature, figuring it was the double click built in delay, but it was not. Then after some pondering, and trying many random different things to perhaps get a clue, one clue did appear. I noticed if you were “moving” the mouse pointer inside the cell when clicking real fast in the cell, the color would change right away.
<o></o>
Have not figured out why moving the mouse somehow resets the cell to receive the next click immediately. But whatever the reason, added below code that moves the mouse 4 pixels either right or left after each click. A 2 pixel move will do it, but you might accidentally move mouse 2 pixels in the opposite direction when clicking, which cancels out the effect. I tried resetting 4 pixels to the left after a 4 pixel move to the right so it would appear as the mouse did not even moved, but a left pixel move immediately after a right pixel move cancels the effect, and fast clicking would no longer work. Now you can right click as fast as you want and the colors change with each click immediately.

Option Explicit
Dim MyPointAPI As POINTAPI
Private Type POINTAPI
  X As Long
  Y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
 
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'
'To highlight a cell with a background color, right click on a cell
'Keep right clicking to change to desired color.
 
    Static ToggleLR As Integer
    Dim tmp As Integer
    Dim cLightGREEN, cMediumGREEN, cBrightGREEN, cDullGREEN, cDullYELLOW, cBrightYELLOW, cDullRED, cBrightRED
 
    cBrightGREEN = 65280
    cDullGREEN = 5296274
    cDullYELLOW = 6750207
    cDullRED = 8420607
        'Colors not currently used
    cLightGREEN = 10092492
    cMediumGREEN = 3407820
    cBrightYELLOW = 65535
    cBrightRED = 255
 
    If Intersect(Target, Range("B2:G10")) Is Nothing Then Exit Sub 'SYMBOL column
    Application.EnableEvents = False
 
    Cancel = True 'disable the right click menus so they do not pop up in range
        'Is cell blank background, no fill
    With Target.Interior
        Select Case .Color
            Case xlNone: .Color = cBrightGREEN 'was BLANK
                Target.Offset(0, 100).Interior.Color = cBrightGREEN 'mirror image color over 100 col's
            Case cBrightGREEN: .Color = cDullGREEN
                Target.Offset(0, 100).Interior.Color = cDullGREEN
            Case cDullGREEN: .Color = cDullYELLOW
                Target.Offset(0, 100).Interior.Color = cDullYELLOW
            Case cDullYELLOW: .Color = cDullRED
                Target.Offset(0, 100).Interior.Color = cDullRED
            Case cDullRED: .Color = xlNone  'make it BLANK, NO FILL
                Target.Offset(0, 100).Interior.Color = xlNone
            Case Else: .Color = cBrightGREEN 'If any other color, and not blank
                Target.Offset(0, 100).Interior.Color = cBrightGREEN
        End Select
    End With
 
        'MOVE CURSOR SLIGHTLY TO RIGHT OR LEFT
        'For some reason right click has a delay between clicks unless the mouse cursor is moved
        'by at least 2 pixels. Works if move only one direction per click.
    tmp = GetCursorPos(MyPointAPI) 'get our cursor position first
        'MsgBox CStr(MyPointAPI.X) & ", " & CStr(MyPointAPI.Y) 'for testing, displays cursor X Y coordinates
        'Following functions will need the above lib "user32" declarations
    If ToggleLR = 1 Then
        ToggleLR = 0
        Call SetCursorPos(MyPointAPI.X + 4, MyPointAPI.Y) 'move cursor to right 4 pixels
    Else
        ToggleLR = 1
        Call SetCursorPos(MyPointAPI.X - 4, MyPointAPI.Y) 'move cursor to left 4 pixels
    End If
 
    Application.EnableEvents = True
End Sub

 

[tom_]

very helpful. Thank you!

 

[tom_]

Just a follow up question for this thread...(from a beginner!)
I am using this feature to check off names very quickly off a list.

My question:
Is there any way I can get the same names (stacked in a completely different order) to change color on another sheet -- when I change (double click) on sheet 1?

I am guessing I would have to match the names from sheet 1 on sheet 2 by using =sheet1!C3 (for example). But when I have tried this, the format (color) change does not carry over to sheet 2.

Any ideas? Thanks in advance,

Tom