Colour Changing Cells depending on number of clicks

MartinPES

New Member
Joined
Oct 9, 2024
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hi to the fonts of all Excel knowledge..:)
So here goes...
I have a document that i want to be able to change the colour of the cells just by clicking it. I need to develop a check sheet that will have a column of cells that start off blank and change from green to amber to red depending on the number of clicks/taps you make.

I found on here a code that makes a cell turn green but then nothing else as shown below, are we able to edit the code to make the full green amber red thing work?

1728482566219.png



I sit quietly in anticipation of your wisdom. ☺️
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Hi to the fonts of all Excel knowledge..:)
So here goes...
I have a document that i want to be able to change the colour of the cells just by clicking it. I need to develop a check sheet that will have a column of cells that start off blank and change from green to amber to red depending on the number of clicks/taps you make.

I found on here a code that makes a cell turn green but then nothing else as shown below, are we able to edit the code to make the full green amber red thing work?

View attachment 117888


I sit quietly in anticipation of your wisdom. ☺️
Welcome to Mr Excel.

Are you still sitting in anticipation.

Try this.

It can be tweaked.

You can get the RGB colours from this site. Color Schemer - Online Color Scheme Generator

VBA Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  If Target.CountLarge > 1 Then
    Exit Sub
  End If
  
  If Not Intersect(Range("B2:B8"), Target) Is Nothing Then
    
    Select Case Target.Interior.Color
    
      Case RGB(0, 255, 0): ' Green to Amber
          
        Target.Interior.Color = RGB(255, 191, 0)
      
      Case RGB(255, 191, 0): ' Amber to Red
      
        Target.Interior.Color = RGB(255, 0, 0)
      
      Case RGB(255, 0, 0): ' Red to Blank
      
        Target.Interior.Color = RGB(255, 255, 255)
      
      Case Else: ' Blank to Green
      
        Target.Interior.Color = RGB(0, 255, 0)
      
    End Select
    
    Range("B1").Select
  
  End If

End Sub
 
Upvote 1
Solution
Welcome to Mr Excel.

Are you still sitting in anticipation.

Try this.

It can be tweaked.

You can get the RGB colours from this site. Color Schemer - Online Color Scheme Generator

VBA Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  If Target.CountLarge > 1 Then
    Exit Sub
  End If
 
  If Not Intersect(Range("B2:B8"), Target) Is Nothing Then
   
    Select Case Target.Interior.Color
   
      Case RGB(0, 255, 0): ' Green to Amber
         
        Target.Interior.Color = RGB(255, 191, 0)
     
      Case RGB(255, 191, 0): ' Amber to Red
     
        Target.Interior.Color = RGB(255, 0, 0)
     
      Case RGB(255, 0, 0): ' Red to Blank
     
        Target.Interior.Color = RGB(255, 255, 255)
     
      Case Else: ' Blank to Green
     
        Target.Interior.Color = RGB(0, 255, 0)
     
    End Select
   
    Range("B1").Select
 
  End If

End Sub
That is perfect and works like a dream. I can now move on with my life. :LOL:. Thanks.
 
Upvote 0
That is perfect and works like a dream. I can now move on with my life. :LOL:. Thanks

That is perfect and works like a dream. I can now move on with my life. :LOL:. Thanks.
I have made one change.

Instead of a background of white for blank it now changes it to No Fill which is the default Excel cell interior.

VBA Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  If Target.CountLarge > 1 Then
    Exit Sub
  End If
  
  If Not Intersect(Range("B2:B8"), Target) Is Nothing Then
    
    Select Case Target.Interior.Color
    
      Case RGB(0, 255, 0): ' Green to Amber
          
        Target.Interior.Color = RGB(255, 191, 0)
      
      Case RGB(255, 191, 0): ' Amber to Red
      
        Target.Interior.Color = RGB(255, 0, 0)
      
      Case RGB(255, 0, 0): ' Red to Blank
      
        ' This is the previous line.
        ' Target.Interior.Color = RGB(255, 255, 255)
        
        With Target.Interior
          .Pattern = xlNone
          .TintAndShade = 0
          .PatternTintAndShade = 0
        End With
      
      Case Else: ' Blank to Green
      
        Target.Interior.Color = RGB(0, 255, 0)
      
    End Select
    
    Range("B1").Select
  
  End If

End Sub
 
Upvote 0
Welcome to the MrExcel board!

I was having a play around with this to see if there were shorter or different ways and have a couple of observations & a possible alternative.

I was slightly put off by the cursor flashing up to B1 all the time and if the relevant range became large something different might be needed there anyway so I have used code that changes the colour when the cell is right-clicked instead of a left-clicked (ie selected). This leaves the clicked cell as the active cell. Another alternative would be to double-click the cell and use the BeforeDoubleClick event instead of BeforeRightClick.

I have assumed that the range in question will never have any other colour(s) applied else the code would need a tweak to avoid erroring.

Anyway, if you feel like it, you could give this a try.

VBA Code:
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  Dim Clrs As Variant

  Clrs = Split("65280 49151 255 16777215") '(Green Amber Red None)
  With Target
    If .CountLarge = 1 And Not Intersect(Target, Range("B2:B8")) Is Nothing Then
      Cancel = True
      .Interior.Color = Clrs(Application.Match(CStr(.Interior.Color), Clrs, 0) Mod 4)
    End If
  End With
End Sub
 
Upvote 0
In my unfortunate excitement i have now tested this on the intended device (android tablet running Office365) and it says that the version of excel doesnt support VBA....

Any way around this guys?
 
Upvote 0
Hmm, ok so I have purchased a surface pro and installed an on device version of Excel which now works well. However, What I am not liking is how it jumps to B1 once the cells I am working on become further down the page. How can stop it from doing this and hopefully just remaining on the cell I worked on last or by dropping down to the next cell below? I can see in the code B1 but not sure how, what, where and why.. ;)
 
Upvote 0
What I am not liking is how it jumps to B1 once the cells I am working on become further down the page. How can stop it from doing this and hopefully just remaining on the cell I worked on last or by dropping down to the next cell below?
Did you read post #5?

Or if you do really want to stick to the left click to change the colours you could try this event code. note though that with the code below, it will run every time you select any cells/range on the worksheet.
It will only colour if a single cell in the target range is selected but running on every selection seems inefficient to me. Anyway, your choice. :)

or by dropping down to the next cell below?
Note that I have instead moved to the cell to the right. The reason is that if we moved down one, say from B3 to B4 and you then wanted to change the colour of B4, clicking on it would not fire this code because, with B4 already being selected, clicking on it does not change the selection and therefore does not fire this code. The same thing would happen if we kept the clicked cell as the active cell and you wanted to click on on again straight away to change the colour again because once again there would be no Selection_Change. (The right-click code I suggested earlier does not have this issue)

VBA Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim Clrs As Variant

  With Target
    If .CountLarge = 1 And Not Intersect(Target, Range("B2:B8")) Is Nothing Then
      Clrs = Split("65280 49151 255 16777215") '(Green Amber Red None)
      Cancel = True
      .Interior.Color = Clrs(Application.Match(CStr(.Interior.Color), Clrs, 0) Mod 4)
      Application.EnableEvents = False
      .Offset(, 1).Select
      Application.EnableEvents = True
    End If
  End With
End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,224,547
Messages
6,179,436
Members
452,915
Latest member
hannnahheileen

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