Colour Cell background based on cell values

[Rem0ram]

Hi

This is a query already posted in another thread, any advise will be helpful

http://www.excelforum.com/excel-programming-vba-macros/1035028-colour-cell-background-based-on-cell-values.html

[SamT]

Link to file at ExcelForum: File

I leave you to discover which ColorIndex numbers are the ones you want. Hint' For each Cel in Range, where Range values are 1 to 56, set the color to the Range's value

Option Explicit

Sub CellColor()

Const Black As Long = 1
Const Red As Long = 3
Const Yellow As Long = 4 'Adjust to fit
Const Amber As Long = 5 'Adjust to fit

  Dim Cel As Range
  Dim LastRow As Long
  LastRow = Cells(Rows.Count, 8).End(xlUp).Row
  
  For Each Cel In Range("H2:H" & CStr(LastRow))
    If IsError(Cel.Value) Then GoTo AfterSelect
    Select Case Cel.Value
      Case Is > 1
        Cel.Interior.ColorIndex = Red
      Case Is > 0.9
        Cel.Interior.ColorIndex = Amber
      Case Is > 0.85
        Cel.Interior.ColorIndex = Yellow
      Case Is < 0
        Cel.Interior.ColorIndex = Black
      Case Else
    End Select
AfterSelect:
Next Cel
End Sub

If this solves your problem, use the Tread Tools at the top to mark this thread Solved, then go back to your thread on ExcelForum, post this code and mark that thread solved, so readers there can find the solution.

[Rem0ram]

Hi SamT

Thanks for the code, however when I run them in my workbook it altogether updates with different colour.

for values between 0.85 and 100 it updates blue colour

[Rem0ram]

Hi SamT

Its working fine now.

Thanks

[SamT]

[Rem0ram]

Hi SamT

Thanks for the solution.

Now I face a new challenge here, for those cases i want to check the range for colouring the cell.

Const Black As Long = 1
    Const Red As Long = 3
    Const Yellow As Long = 6 'Adjust to fit
    Const Amber As Long = 45 'Adjust to fit
     
    Dim Cel As Range
    Dim LastRow As Long
    LastRow = Cells(Rows.Count, 8).End(xlUp).Row
     
    For Each Cel In Range("H2:H" & CStr(LastRow))
        If IsError(Cel.Value) Then GoTo AfterSelect
        Select Case Cel.Value
        Case Is >= 0.999
            Cel.Interior.ColorIndex = Red
        Case Is > 0.901 To <= 0.9945
            Cel.Interior.ColorIndex = Amber
        Case Is >= 0.845 To <= 0.9945
            Cel.Interior.ColorIndex = Yellow
        Case Is < 0
            Cel.Interior.ColorIndex = Black
            Cel.Font.ColorIndex = 2
        Case Else
        End Select
AfterSelect:
    Next Cel

If you could advise how to resolve that would be helpful.

[SamT]

Now I face a new challenge here, for those cases i want to check the range for colouring the cell.

I don't understand.

However I see a problem in that Select Case function. Since Excel calculates values to (IIRC) 32 places, but only displays values according to formatting rules, you have left gaps in the coverage by using Case m To n with only 4 significant digits.

The solution: When any given Case is met, the execution leaves the Select Case before the next Case. Just use Case >= 0.mmm in all Cases.

Case Else will be met by Cel.Value = 0.

The If IsError() line is needed because the Value of Errors can be >= 1.

I am guessing about your challenge, but would not that same Sub work by only changing the Select case to

Select Case Cel.Interior.ColorIndex

[Rem0ram]

Hi SamT

Not sure what your suggestion in the last line.

I have managed to make it work the way i wanted as below.

Const Black As Long = 1
    Const Red As Long = 3
    Const Yellow As Long = 6 'Adjust to fit
    Const Amber As Long = 45 'Adjust to fit
     
    Dim Cel As Range
    Dim LastRow As Long
    LastRow = Cells(Rows.Count, 8).End(xlUp).Row
     
    For Each Cel In Range("H2:H" & CStr(LastRow))
        If IsError(Cel.Value) Then GoTo AfterSelect
        Select Case Cel.Value
        Case Is >= 0.995
            Cel.Interior.ColorIndex = Red
        Case 0.895 To 0.9949
            Cel.Interior.ColorIndex = Amber
        Case 0.845 To 0.8949
            Cel.Interior.ColorIndex = Yellow
        Case Is < 0
            Cel.Interior.ColorIndex = Black
            Cel.Font.ColorIndex = 2
        Case Else
        End Select
AfterSelect:
    Next Cel

But still im concerned there might be hidden bomb.

[SamT]

you are not sure about my suggestion, because I am not sure about your challenge.

I see the possibility of a lot of hidden bombs in there. What happens if the actual Cel.Value is 0.99495

If you use this version, there will be no "significant digit" bombs, but the code works the same as yours.

   Select Case Cel.Value 
    Case Is >= 0.995 
        Cel.Interior.ColorIndex = Red 
    Case Is >=0.895
        Cel.Interior.ColorIndex = Amber 
    Case Is >=0.845
        Cel.Interior.ColorIndex = Yellow 
    Case Is > 0
        'Not needed at this time. Do Nothing
    Case Is <= 0 
        Cel.Interior.ColorIndex = Black 
        Cel.Font.ColorIndex = 2 
    Case Else

Notice how the Cases are descending in value. That is why this works the same as yours.

[Rem0ram]

Hi SamT

Thanks will check on your input.