Conditional Formatting on computed field

[jrhugh]

Good day,

I created a spreadsheet to automate my risk rating activities.

I created two (2) drop-down lists cells:
1-Frequency of activity
2-Impact

I created another cell that automatically (based on the Index and Match functions) generates a risk rating based on the Frequency and Impact combinations. The formula in this cell reference to another worksheet where I have the risk rating matrix for the Frequency and Impact.

Objective:
Depending on the risk rating (e.g. Extreme, Very High, High, Moderate, Low), I want the risk rating cell to also place a color in the cell (e.g. red, yellow, orange, blue and green respectively).

I used the VBA macro from one of the articles on this site (title "Conditional Formatting (More Than Three)" to do this. I modified it for my risk ratings.

However, I noted that after making the impact and frequency selections, and the risk rating cell automatically populates with the corresponding risk rating, it color also does not also show. I have to go into the cell and click in it, then press enter for the color to come on.

Can anyone help me with this one????

Also, I only want the risk rating cell range to be colored, and not all cells.

Note that I am a novice with VBA.

I have attached a copy of the spreadsheet.

Kind regards

[Bob Phillips]

Try this



Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
If Not Intersect(Target, Me.Columns("A:C")) Is Nothing Then
With Me.Cells(Target.Row, "C")
If Not IsError(.Value2) Then
Select Case LCase(.Value2)
Case vbNullString
.Interior.ColorIndex = xlNone
.Font.Bold = False
Case "extreme"
.Interior.ColorIndex = 3
.Font.Bold = True
Case "very high"
.Interior.ColorIndex = 6
.Font.Bold = True
Case "high"
.Interior.ColorIndex = 46
.Font.Bold = True
Case "moderate"
.Interior.ColorIndex = 23
.Font.Bold = True
Case "low"
.Interior.ColorIndex = 4
.Font.Bold = True
Case Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End Select
End If
End With
End If
End Sub

[jrhugh]

Thanks a million XLD. It works great. The only thing is that if I take off the options, the cells remain with the colors. Is there a way to reset back to the original?:bow::bow:

[jrhugh]

Also, how do I change the "With Me.Cells(Target.Row, "C")" to include another column for shading also. Thanks in advance.:help

[Bob Phillips]

Thanks a million XLD. It works great. The only thing is that if I take off the options, the cells remain with the colors. Is there a way to reset back to the original?:bow::bow:

You add an Else to cater for the error in the If clause



Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
If Not Intersect(Target, Me.Columns("A:C")) Is Nothing Then
With Me.Cells(Target.Row, "C")
If Not IsError(.Value2) Then
Select Case LCase(.Value2)
Case vbNullString
.Interior.ColorIndex = xlNone
.Font.Bold = False
Case "extreme"
.Interior.ColorIndex = 3
.Font.Bold = True
Case "very high"
.Interior.ColorIndex = 6
.Font.Bold = True
Case "high"
.Interior.ColorIndex = 46
.Font.Bold = True
Case "moderate"
.Interior.ColorIndex = 23
.Font.Bold = True
Case "low"
.Interior.ColorIndex = 4
.Font.Bold = True
Case Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End Select
Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End If
End With
End If
End Sub

[Bob Phillips]

Also, how do I change the "With Me.Cells(Target.Row, "C")" to include another column for shading also. Thanks in advance.:help

If you want to include column D, you just resize the case action




Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
If Not Intersect(Target, Me.Columns("A:C")) Is Nothing Then
With Me.Cells(Target.Row, "C")
If Not IsError(.Value2) Then
Select Case LCase(.Value2)
Case vbNullString
.Resize(, 2).Interior.ColorIndex = xlNone
.Resize(, 2).Font.Bold = False
Case "extreme"
.Resize(, 2).Interior.ColorIndex = 3
.Resize(, 2).Font.Bold = True
Case "very high"
.Resize(, 2).Interior.ColorIndex = 6
.Resize(, 2).Font.Bold = True
Case "high"
.Resize(, 2).Interior.ColorIndex = 46
.Resize(, 2).Font.Bold = True
Case "moderate"
.Resize(, 2).Interior.ColorIndex = 23
.Resize(, 2).Font.Bold = True
Case "low"
.Resize(, 2).Interior.ColorIndex = 4
.Resize(, 2).Font.Bold = True
Case Else
.Resize(, 2).Interior.ColorIndex = xlNone
.Resize(, 2).Font.Bold = False
End Select
Else
.Resize(, 2).Interior.ColorIndex = xlNone
.Resize(, 2).Font.Bold = False
End If
End With
End If
End Sub

[jrhugh]

You add an Else to cater for the error in the If clause



Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
If Not Intersect(Target, Me.Columns("A:C")) Is Nothing Then
With Me.Cells(Target.Row, "C")
If Not IsError(.Value2) Then
Select Case LCase(.Value2)
Case vbNullString
.Interior.ColorIndex = xlNone
.Font.Bold = False
Case "extreme"
.Interior.ColorIndex = 3
.Font.Bold = True
Case "very high"
.Interior.ColorIndex = 6
.Font.Bold = True
Case "high"
.Interior.ColorIndex = 46
.Font.Bold = True
Case "moderate"
.Interior.ColorIndex = 23
.Font.Bold = True
Case "low"
.Interior.ColorIndex = 4
.Font.Bold = True
Case Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End Select
Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End If
End With
End If
End Sub
The second change with the Else statements works perfectly. Thanks.:bow:

Regarding making shading to another cell, I wanted to include a condition for another cell, not to expand the shading. For example, after we determine the risk (C), and take the procedures into account, we come up with the residual risk (G). G may give a different risk rating, and therefore I would like to shade the results in G also. See attached for example.

I am very grateful for the assistance that you have provided.

Regards,
JrHugh.

[Bob Phillips]

That takes a lot more work, you can't just extend the comparison range, the action is different in some cases.

This can probably be mproved upon, but I think that it works.



Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
If Not Intersect(Target, Me.Columns("A:C")) Is Nothing Then
Call ExtremeToLow(Me.Cells(Target.Row, "C"))
ElseIf Not Intersect(Target, Me.Columns("D")) Is Nothing Or _
Not Intersect(Target, Me.Columns("F")) Is Nothing Then
With Me.Cells(Target.Row, "F")
If Not IsError(.Value2) Then
Select Case LCase(.Value2)
Case vbNullString
.Interior.ColorIndex = xlNone
.Font.Bold = False
Case "poor"
.Interior.ColorIndex = 3
.Font.Bold = True
Case "weak"
.Interior.ColorIndex = 6
.Font.Bold = True
Case "fair"
.Interior.ColorIndex = 46
.Font.Bold = True
Case "good"
.Interior.ColorIndex = 23
.Font.Bold = True
Case "excellent"
.Interior.ColorIndex = 4
.Font.Bold = True
Case Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End Select
Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End If
End With
ElseIf Not Intersect(Target, Me.Columns("E")) Is Nothing Or _
Not Intersect(Target, Me.Columns("G")) Is Nothing Then
Call ExtremeToLow(Me.Cells(Target.Row, "G"))
End If
End Sub

Private Function ExtremeToLow(ByRef CellToFlag As Range)
With CellToFlag
If Not IsError(.Value2) Then
Select Case LCase(.Value2)
Case vbNullString
.Interior.ColorIndex = xlNone
.Font.Bold = False
Case "extreme"
.Interior.ColorIndex = 3
.Font.Bold = True
Case "very high"
.Interior.ColorIndex = 6
.Font.Bold = True
Case "high"
.Interior.ColorIndex = 46
.Font.Bold = True
Case "moderate"
.Interior.ColorIndex = 23
.Font.Bold = True
Case "low"
.Interior.ColorIndex = 4
.Font.Bold = True
Case Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End Select
Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End If
End With
End Function

[Bob Phillips]

Soory, couldn't leave it with that rubbish code



Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
If Not Intersect(Target, Me.Columns("A:C")) Is Nothing Then
Call FlagResult(Me.Cells(Target.Row, "C"), Array(Null, "extreme", "very high", "high", "moderate", "low"))
ElseIf Not Intersect(Target, Me.Columns("D")) Is Nothing Or _
Not Intersect(Target, Me.Columns("F")) Is Nothing Then
Call FlagResult(Me.Cells(Target.Row, "G"), Array(Null, "poor", "weak", "fair", "good", "excellent"))
ElseIf Not Intersect(Target, Me.Columns("E")) Is Nothing Or _
Not Intersect(Target, Me.Columns("G")) Is Nothing Then
Call FlagResult(Me.Cells(Target.Row, "G"), Array(Null, "extreme", "very high", "high", "moderate", "low"))
End If
End Sub

Private Function FlagResult(ByRef CellToFlag As Range, ByVal Cases As Variant)
With CellToFlag
If Not IsError(.Value2) Then
Select Case LCase(.Value2)
Case Cases(0)
.Interior.ColorIndex = xlNone
.Font.Bold = False
Case Cases(1)
.Interior.ColorIndex = 3
.Font.Bold = True
Case Cases(2)
.Interior.ColorIndex = 6
.Font.Bold = True
Case Cases(3)
.Interior.ColorIndex = 46
.Font.Bold = True
Case Cases(4)
.Interior.ColorIndex = 23
.Font.Bold = True
Case Cases(5)
.Interior.ColorIndex = 4
.Font.Bold = True
Case Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End Select
Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End If
End With
End Function

[jrhugh]

Thanks, I am going to try that and let you know. However, did the following which seem to work, but I am sure your way is 100% better. Note reference to column F and J. My original spread sheet has more column, and those are the columns that have the Risk and Residual Risk. In essence, I just copied a section of the statement you gave me. Let me know. Thanks a million.


Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
If Not Intersect(Target, Me.Columns("A:O")) Is Nothing Then
With Me.Cells(Target.Row, "F")
If Not IsError(.Value2) Then
Select Case LCase(.Value2)
Case vbNullString
.Interior.ColorIndex = xlNone
.Font.Bold = False
Case "extreme"
.Interior.ColorIndex = 3
.Font.Bold = True
Case "very high"
.Interior.ColorIndex = 6
.Font.Bold = True
Case "high"
.Interior.ColorIndex = 46
.Font.Bold = True
Case "moderate"
.Interior.ColorIndex = 23
.Font.Bold = True
Case "low"
.Interior.ColorIndex = 4
.Font.Bold = True
Case Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End Select
Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End If
End With
With Me.Cells(Target.Row, "J")
If Not IsError(.Value2) Then
Select Case LCase(.Value2)
Case vbNullString
.Interior.ColorIndex = xlNone
.Font.Bold = False
Case "extreme"
.Interior.ColorIndex = 3
.Font.Bold = True
Case "very high"
.Interior.ColorIndex = 6
.Font.Bold = True
Case "high"
.Interior.ColorIndex = 46
.Font.Bold = True
Case "moderate"
.Interior.ColorIndex = 23
.Font.Bold = True
Case "low"
.Interior.ColorIndex = 4
.Font.Bold = True
Case Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End Select
Else
.Interior.ColorIndex = xlNone
.Font.Bold = False
End If
End With
End If
End Sub

[Bob Phillips]

I think my last version is far more flexible. You can add new conditions that work on a comletely different set of result strings very easily. Also, yours does them all regardless, mine just homes in on the changed flags.

[jrhugh]

Hi XLD,

I protected the worksheet, as I do not want the end users to see the formulas cells. However, when this is done, I get an error from the Marco. See attached.

Do you have any idea why this may be happening?

[Bob Phillips]

You need to unprotect the sheet in the code, do the action, then protect it again.

[Bob Phillips]

You could also remove the formula and write the value from the code!