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

 

[MartinPES]

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

 

[Peter_SSs]

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)

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