View Full Version : Solved: Conditional Formatting Via Worksheet Event Code
jdubya
10-29-2010, 06:46 AM
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
10-29-2010, 07:06 AM
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
10-29-2010, 07:32 AM
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
10-29-2010, 08:09 AM
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
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
10-29-2010, 08:41 AM
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
10-29-2010, 08:53 AM
Hey, picky! :whistle:
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
jdubya
10-29-2010, 10:02 AM
Hey, picky! :whistle:
:rotlaugh:
Bob, thanks for your help!
Bob Phillips
10-29-2010, 04:13 PM
I have moved the cell clearing to before the values tests.
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
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
10-29-2010, 11:50 PM
very useful thread
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.