Solved: Conditional Formatting Via Worksheet Event Code

[jdubya]

Hi All,

I monitor water samples for the level of certain metals and pH. There are three conditions that need to be checked for the metals:
1. Exceeds EPA criteria.
2. Exceeds State Permit criteria.
3. Exceeds both EPA and State Permit criteria.


pH criteria are the same for both EPA and State Permit, pH shall not be less than 6.0 nor greater than 9.0.


For each metal that exceeds its criteria, I would like the cell to be color coded and the font bolded per the example in the attached workbook.


The data is kept in the "Data" worksheet. Both EPA and State Permit Criteria are listed in the "Criteria" worksheet.


I'm using Excel 2007.


Any help would be appreciated.

[Bob Phillips]

I am confused by the values with < in them, as these do not tell you what the value is. For instance, if the Cd said <.7, does that fail the .69 criteria or not?

[jdubya]

I am confused by the values with < in them, as these do not tell you what the value is. For instance, if the Cd said <.7, does that fail the .69 criteria or not?

Bob, sorry about the confusion.

Our instrumentation is calibrated with 0.1 ppm standards, so if a reading on an element is less than our standard, we report it as < 0.1. Any reading greater than 0.1 will be reported as such.

In other words, anything less than 0.7 will meet the criteria, but it wouldn't be listed as < 0.7. It would be listed as the actual number (e.g., 0.65, 0.21, etc.).

[Bob Phillips]

[vba]

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE_NOT_PH As String = "C:J"
Const WS_RANGE_PH As String = "K:K"
Const CI_EPA As Long = 52479
Const CI_STATE_PERMIT As Long = 65535
Const CI_BOTH As Long = 9803737

Dim wsCriteria As Worksheet

On Error GoTo ws_exit

Application.EnableEvents = False

Set wsCriteria = Worksheets("Criteria")

If Not Intersect(Target, Me.Range(WS_RANGE_NOT_PH)) Is Nothing Then

With Target

If .Row > 2 Then

If .Value <> "<0.1" And .Value <> "" Then

Select Case True

Case .Value > wsCriteria.Cells(3, .Column - 1).Value2 And _
.Value > wsCriteria.Cells(4, .Column - 1).Value2:

.Interior.Color = CI_BOTH

Case .Value > wsCriteria.Cells(3, .Column - 1).Value2:

.Interior.Color = CI_EPA

Case .Value > wsCriteria.Cells(4, .Column - 1).Value2:

.Interior.Color = CI_STATE_PERMIT
End Select
End If
End If
End With

ElseIf Not Intersect(Target, Me.Range(WS_RANGE_PH)) Is Nothing Then

With Target

If .Row > 2 Then

If .Value <> "<0.1" And .Value <> "" Then

Select Case True

Case (.Value < wsCriteria.Cells(3, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(3, .Column).Value2) And _
(.Value < wsCriteria.Cells(4, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(4, .Column).Value2):

.Interior.Color = CI_BOTH

Case .Value < wsCriteria.Cells(3, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(3, .Column).Value2:

.Interior.Color = CI_EPA

Case .Value < wsCriteria.Cells(4, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(4, .Column).Value2:

.Interior.Color = CI_STATE_PERMIT
End Select
End If
End If
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub
[/vba]

This is worksheet event code, which means that it needs to be
placed in the appropriate worksheet code module, not a standard
code module. To do this, right-click on the sheet tab, select
the View Code option from the menu, and paste the code in.

[jdubya]

Bob,

Thank you for the code.

A couple of things:

1. If a value exceeds criteria, the font doesn't bold.
2. Cell color is not removed if a value is initially entered, exceeding criteria, but changed to a value that meets criteria (the cell remains colored).

Thanks!

[Bob Phillips]

Hey, picky!

[vba]
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE_NOT_PH As String = "C:J"
Const WS_RANGE_PH As String = "K:K"
Const CI_EPA As Long = 52479
Const CI_STATE_PERMIT As Long = 65535
Const CI_BOTH As Long = 9803737

Dim wsCriteria As Worksheet

On Error GoTo ws_exit

Application.EnableEvents = False

Set wsCriteria = Worksheets("Criteria")

If Not Intersect(Target, Me.Range(WS_RANGE_NOT_PH)) Is Nothing Then

With Target

If .Row > 2 Then

If .Value <> "<0.1" And .Value <> "" Then

.Interior.ColorIndex = xlColorIndexNone
.Font.Bold = False

Select Case True

Case .Value > wsCriteria.Cells(3, .Column - 1).Value2 And _
.Value > wsCriteria.Cells(4, .Column - 1).Value2:

.Interior.Color = CI_BOTH
.Font.Bold = True

Case .Value > wsCriteria.Cells(3, .Column - 1).Value2:

.Interior.Color = CI_EPA
.Font.Bold = True

Case .Value > wsCriteria.Cells(4, .Column - 1).Value2:

.Interior.Color = CI_STATE_PERMIT
.Font.Bold = True
End Select
End If
End If
End With

ElseIf Not Intersect(Target, Me.Range(WS_RANGE_PH)) Is Nothing Then

With Target

If .Row > 2 Then

If .Value <> "<0.1" And .Value <> "" Then

.Interior.ColorIndex = xlColorIndexNone
.Font.Bold = False

Select Case True

Case (.Value < wsCriteria.Cells(3, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(3, .Column).Value2) And _
(.Value < wsCriteria.Cells(4, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(4, .Column).Value2):

.Interior.Color = CI_BOTH
.Font.Bold = True

Case .Value < wsCriteria.Cells(3, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(3, .Column).Value2:

.Interior.Color = CI_EPA
.Font.Bold = True

Case .Value < wsCriteria.Cells(4, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(4, .Column).Value2:

.Interior.Color = CI_STATE_PERMIT
.Font.Bold = True
End Select
End If
End If
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub
[/vba]

[jdubya]

Hey, picky!

Bob, thanks for your help!

[Bob Phillips]

I have moved the cell clearing to before the values tests.

[vba]

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE_NOT_PH As String = "C:J"
Const WS_RANGE_PH As String = "K:K"
Const CI_EPA As Long = 52479
Const CI_STATE_PERMIT As Long = 65535
Const CI_BOTH As Long = 9803737

Dim wsCriteria As Worksheet

On Error GoTo ws_exit

Application.EnableEvents = False

Set wsCriteria = Worksheets("Criteria")

If Not Intersect(Target, Me.Range(WS_RANGE_NOT_PH)) Is Nothing Then

With Target

If .Row > 2 Then

.Interior.ColorIndex = xlColorIndexNone
.Font.Bold = False

If .Value <> "<0.1" And .Value <> "" Then

Select Case True

Case .Value > wsCriteria.Cells(3, .Column - 1).Value2 And _
.Value > wsCriteria.Cells(4, .Column - 1).Value2:

.Interior.Color = CI_BOTH
.Font.Bold = True

Case .Value > wsCriteria.Cells(3, .Column - 1).Value2:

.Interior.Color = CI_EPA
.Font.Bold = True

Case .Value > wsCriteria.Cells(4, .Column - 1).Value2:

.Interior.Color = CI_STATE_PERMIT
.Font.Bold = True
End Select
End If
End If
End With

ElseIf Not Intersect(Target, Me.Range(WS_RANGE_PH)) Is Nothing Then

With Target

If .Row > 2 Then

.Interior.ColorIndex = xlColorIndexNone
.Font.Bold = False

If .Value <> "<0.1" And .Value <> "" Then

Select Case True

Case (.Value < wsCriteria.Cells(3, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(3, .Column).Value2) And _
(.Value < wsCriteria.Cells(4, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(4, .Column).Value2):

.Interior.Color = CI_BOTH
.Font.Bold = True

Case .Value < wsCriteria.Cells(3, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(3, .Column).Value2:

.Interior.Color = CI_EPA
.Font.Bold = True

Case .Value < wsCriteria.Cells(4, .Column - 1).Value2 Or _
.Value > wsCriteria.Cells(4, .Column).Value2:

.Interior.Color = CI_STATE_PERMIT
.Font.Bold = True
End Select
End If
End If
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub
[/vba]

If you insert any columns, you need to modify the two constant values WS_RANGE_NOT_PH and WS_RANGE_PH. The first applies to all of the non PH columns on the Criteria sheet, the second applies to the first column of the PH min and max.

[rafi_07max]

very useful thread