Colour Changing Cells depending on number of clicks

[MartinPES]

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?

I sit quietly in anticipation of your wisdom.

 

[HighAndWilder]

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

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

 

[MartinPES]

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

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. . Thanks.

 

[HighAndWilder]

That is perfect and works like a dream. I can now move on with my life. . Thanks

That is perfect and works like a dream. I can now move on with my life. . 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.

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

 

[Peter_SSs]

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.

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

 

[MartinPES]

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?

 

[Peter_SSs]

Any way around this guys?

As far as I am aware: No