Change the interior color of a cell - Code Review

Tiny Tim · 12-16-2005, 06:00 PM

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

JE McGimpsey · 12-16-2005, 08:45 PM

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

In article <[email protected]>,
Tiny Tim <[email protected]> wrote:

> 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

Eric White · 12-16-2005, 09:50 PM

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.

"Tiny Tim" wrote:

> 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
>

Hexman · 12-17-2005, 04:50 AM

On Fri, 16 Dec 2005 17:40:04 -0700, JE McGimpsey
<[email protected]> wrote:

>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
>
>
>In article <[email protected]>,
> Tiny Tim <[email protected]> wrote:
>
>> 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

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

Hexman · 12-17-2005, 05:00 AM

On Fri, 16 Dec 2005 17:46:13 -0800, "Eric White"
<[email protected]> wrote:

>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.
>

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

JE McGimpsey · 12-17-2005, 11:30 AM

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"?

In article <[email protected]>,
Hexman <[email protected]> wrote:

> 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 · 12-17-2005, 05:55 PM

On Sat, 17 Dec 2005 08:27:13 -0700, JE McGimpsey
<[email protected]> wrote:

>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"?
>
>
>In article <[email protected]>,
> Hexman <[email protected]> wrote:
>
>> 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.

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