Change the interior color of a cell - Code Review

T

Tiny Tim

I've developed a routine with brute force rather than finesse that
will change the interior color of a cell in a column if it is within a
certain percentage of either the highest or lowest value in the column
range.

It works, but I'm sure there is a better (more efficient, use of
parameters, use of variables, etc.) or more standardized way of
accomplishing the same.

Could someone please show me the better way? Maybe there's already a
routine out there to do the same.

Thanks,

Hexman
----------------------------------------------------------
The routine is called with:

Call HLCell("F5", 1000, True, 4.5, 22)

rngTop is the column starting cell
cntRows is the # of rows to include in the range
bSrchHigh is for checking either highest or lowest
dPct is percentage from high or low
iColor is the color to highlight the cell

----------------------------------------------------------
Public Sub HLCell(ByVal rngTop As Range, _
ByVal cntRows As Long, _
ByVal bSrchHigh As Boolean, _
ByVal dPct As Double, _
ByVal iColor As Integer)
Dim rngWork As Range
Dim rngWork1 As Range
Dim dMin As Double
Dim dMax As Double
Dim dLowVal As Double
Dim dHighVal As Double
Dim iRow As Integer
Dim iRowCnt As Integer
Dim idx As Integer
Set rngWork = rngTop
Set rngWork1 = rngWork.Offset(cntRows, 0)

iRow = rngWork.Offset(cntRows, 0).End(xlUp).Row
iRowCnt = iRow - rngWork.Row
dMin = 0
dMax = 0
If IsNumeric(rngWork) Then
dMin = rngWork
dMax = rngWork
End If
For idx = 0 To iRowCnt
If IsNumeric(rngWork.Offset(idx, 0)) Then
If rngWork.Offset(idx, 0) > dMax Then
dMax = rngWork.Offset(idx, 0)
End If
If rngWork.Offset(idx, 0) < dMin Then
dMin = rngWork.Offset(idx, 0)
End If
End If
rngWork.Offset(idx, 0).Interior.ColorIndex = xlNone
Next
dHighVal = dMax * (dPct / 100)
dMax = dMax - dHighVal
dLowVal = dMin * (dPct / 100)
dMin = dMin + dLowVal
For idx = 0 To iRowCnt
If IsNumeric(rngWork.Offset(idx, 0)) Then
If bSrchHigh Then
If rngWork.Offset(idx, 0) >= dMax Then
rngWork.Offset(idx, 0).Interior.ColorIndex = _
iColor dk
End If
Else
If rngWork.Offset(idx, 0) <= dMin Then
rngWork.Offset(idx, 0).Interior.ColorIndex = _
iColor
End If
End If
End If
Next
End Sub
 
J

JE McGimpsey

One way:

Public Sub HLCell(ByVal rngTop As Range, _
ByVal cntRows As Long, _
ByVal bSrchHigh As Boolean, _
ByVal dPct As Double, _
ByVal iColor As Integer)
Const dEpsilon As Double = 1.0000000001 'allow for rounding error
Dim rCell As Range
Dim dTarget As Double
Dim dDelta As Double

With rngTop.Resize(cntRows, 1)
With Range(.Cells(1), .Cells(.Count).End(xlUp))
dTarget = IIf(bSrchHigh, Application.Max(.Cells), _
Application.Min(.Cells))
dDelta = Abs((dTarget * dPct / 100) * dEpsilon)
.Interior.ColorIndex = xlColorIndexNone
For Each rCell In .Cells
With rCell
If IsNumeric(.Value) Then _
If Abs(.Value - dTarget) <= dDelta Then _
.Interior.ColorIndex = iColor
End With
Next rCell
End With
End With
End Sub


As an alternative, you can conditionally format your range


Public Sub HLCell(ByVal rngTop As Range, _
ByVal cntRows As Long, _
ByVal bSrchHigh As Boolean, _
ByVal dPct As Double, _
ByVal iColor As Integer)
Const csFormulaTemplate As String = _
"=ABS($$-Target)<(Target*^^%)"
Dim sFormula As String
With Application
sFormula = .Substitute(.Substitute(csFormulaTemplate, _
"^^", dPct), "$$", ActiveCell.Address(False, False))
End With
With rngTop
With Range(.Cells, Cells(.Row + cntRows, .Column).End(xlUp))
.Interior.ColorIndex = xlColorIndexNone
.Parent.Parent.Names.Add _
Name:="Target", _
RefersTo:="=" & IIf(bSrchHigh, "MAX(", "MIN(") & _
.Cells.Address(True, True) & ")"
With .FormatConditions
.Delete
With .Add(Type:=xlExpression, _
Formula1:=sFormula)
.Interior.ColorIndex = iColor
End With
End With
End With
End With
End Sub
 
G

Guest

You don't necessarily have to use code. You could use conditional formatting.

Set the conditional formatting as follows:

Condition 1: Value is greater than or equal to =MAX(RangeName)*((100-x)/100)

Condition 2: Value is less than or equal to = MIN(RangeName)*((100+x)/100)

where RangeName is the specified range and and x is the percentage.
 
H

Hexman

One way:

Public Sub HLCell(ByVal rngTop As Range, _
ByVal cntRows As Long, _
ByVal bSrchHigh As Boolean, _
ByVal dPct As Double, _
ByVal iColor As Integer)
Const dEpsilon As Double = 1.0000000001 'allow for rounding error
Dim rCell As Range
Dim dTarget As Double
Dim dDelta As Double

With rngTop.Resize(cntRows, 1)
With Range(.Cells(1), .Cells(.Count).End(xlUp))
dTarget = IIf(bSrchHigh, Application.Max(.Cells), _
Application.Min(.Cells))
dDelta = Abs((dTarget * dPct / 100) * dEpsilon)
.Interior.ColorIndex = xlColorIndexNone
For Each rCell In .Cells
With rCell
If IsNumeric(.Value) Then _
If Abs(.Value - dTarget) <= dDelta Then _
.Interior.ColorIndex = iColor
End With
Next rCell
End With
End With
End Sub


As an alternative, you can conditionally format your range


Public Sub HLCell(ByVal rngTop As Range, _
ByVal cntRows As Long, _
ByVal bSrchHigh As Boolean, _
ByVal dPct As Double, _
ByVal iColor As Integer)
Const csFormulaTemplate As String = _
"=ABS($$-Target)<(Target*^^%)"
Dim sFormula As String
With Application
sFormula = .Substitute(.Substitute(csFormulaTemplate, _
"^^", dPct), "$$", ActiveCell.Address(False, False))
End With
With rngTop
With Range(.Cells, Cells(.Row + cntRows, .Column).End(xlUp))
.Interior.ColorIndex = xlColorIndexNone
.Parent.Parent.Names.Add _
Name:="Target", _
RefersTo:="=" & IIf(bSrchHigh, "MAX(", "MIN(") & _
.Cells.Address(True, True) & ")"
With .FormatConditions
.Delete
With .Add(Type:=xlExpression, _
Formula1:=sFormula)
.Interior.ColorIndex = iColor
End With
End With
End With
End With
End Sub
Click to expand...


Ah! Much more concise code. In trying the 1st one, an error appears
on the IIF line. The range does contain some non-numeric cells, so I
believe an individual cell test has to be made. I'm assuming the IIF
statement assumes all the cells in the range contains numerics. How
do you get around that if some cells are alpha?

I do like the compactness of your code and would rather use it than my
own.

Hexman
 
H

Hexman

You don't necessarily have to use code. You could use conditional formatting.

Set the conditional formatting as follows:

Condition 1: Value is greater than or equal to =MAX(RangeName)*((100-x)/100)

Condition 2: Value is less than or equal to = MIN(RangeName)*((100+x)/100)

where RangeName is the specified range and and x is the percentage.
Click to expand...

Good point but the range may contain some non-numeric cells. Looks as
if I have to try to convince the user about removing the non-numeric
cells to utilize more efficient code.

Thanks,

Hexman
 
J

JE McGimpsey

No, the presence of Text is not causing your error. Application.Max and
..Min ignore text.

They will not ignore errors, so if you have errors, you should
trap/eliminate them.

What error is appearing "on the IIF line"?
 
H

Hexman

No, the presence of Text is not causing your error. Application.Max and
.Min ignore text.

They will not ignore errors, so if you have errors, you should
trap/eliminate them.

What error is appearing "on the IIF line"?
Click to expand...


Run-time error '13':

Type mismatch.


You're right! In the cell is an error showing "#DIV/0!", which is an
error from one of his previous calculations on another sheet.

When I remove (zero out) the division errors everything works fine.

I know the real solution is to revise the original calculation to
eliminate the error.

Thanks for pointing this out. Again, excellent job of condensing and
streamlining the code.

Hexman
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

A macro that counts cells when the conditional formatting formula =True. i.e. the cell is colored ot 5
Interior color disappears 1
VBA Code to run when any cell is updated 0
Modify sub to work on cells with formulas 2
Amend sheet sub to work if input range contains formulas 2
Conditional Formatting- Refresh 7
Change Interior Cell Color 8
Set text color to interior color 4

Top