Macro to Color Code Cells

  • Thread starter Thread starter Ken
  • Start date Start date
K

Ken

Execl 2000:

We have a workbook with a worksheet that can have a
varying number of rows. The last 5 rows however will
always have data like the following.

A B C
51 Total 70
52
53 Test1 20
54 Test2 75
55 Test3 5

We want the macro to compare the number in B53 to B51. If
B53 is greated than B51, we want A53 and B53 to be
formatted with a green fill color. If B54 is greater than
B51, we want A54 and B54 to have a yellow fill. Otherwise
we want A55 and B55 to be red.

We don't know how to get this to work because the number
of rows will always be different when we run the macro.

Appreciate any assistance.
 
Dim rng as Range
set rng = columns(1).Find("Total")
if not rng is nothing then
if rng.offset(2,1) > rng.offset(0,1) then
rng.offset(2,0).Resize(1,2).Interior.ColorIndex = 4
elseif rng.offset(3,1) > rng.offset(0,1) then
rng.offset(3,0).Resize(1,2).Interior.ColorIndex = 6
else
rng.offset(4,0).Resize(1,2).Interior.ColorIndex = 3
End if
 
HI,

If I understood correctly,

if test1 > total then color green
if test2 > total then color yellow
if neither are colored, color test3 red

The following will do that for you and determine what rows each of those number are based on your information. In summary, The following macro looks at the last used cell on the sheet and work it's way up looking for a value in column 2. When it finds it, it will assign values to all the other row number variables. It will then go through the tests based on the rules above and assign colors accordingly.

Worked fine for me. Let me know if you have any trouble.
(e-mail address removed)
Cheers

'-------cut here and copy to end, then paste on new module in VBA-----------
Dim TestRow1 As Long
Dim TestRow2 As Long
Dim TestRow3 As Long
Dim TotalRow As Long
'
Const Col1 As Integer = 1
Const Col2 As Integer = 2
'
Const ColorGreen As Integer = 4
Const ColorYellow As Integer = 6
Const ColorRed As Integer = 3
'
Dim GreenSw As Boolean
Dim YellowSw As Boolean
'
Sub AddFormats()
'
' Find 3rd test row
TestRow3 = Range("A1").SpecialCells(xlCellTypeLastCell).Row
While Cells(TestRow3, Col2).Value = "" And TestRow3 > 4
TestRow3 = TestRow3 - 1
Wend

If (TestRow3 < 5) Then
MsgBox "No data found"
Exit Sub
End If
'
' Once testrow3 is determined set all row variables based on testrow3
TestRow2 = TestRow3 - 1
TestRow1 = TestRow3 - 2
TotalRow = TestRow3 - 4

' Now you're set to compare
' Green Test--------------------
If (Cells(TestRow1, Col2).Value > Cells(TotalRow, Col2).Value) Then
Range(Cells(TestRow1, Col1), Cells(TestRow1, Col2)).Interior.ColorIndex = ColorGreen
GreenSw = True
Else
Range(Cells(TestRow1, Col1), Cells(TestRow1, Col2)).Interior.ColorIndex = xlNone
GreenSw = False
End If

' Yellow Test-------------------
If (Cells(TestRow2, Col2).Value > Cells(TotalRow, Col2).Value) Then
Range(Cells(TestRow2, Col1), Cells(TestRow2, Col2)).Interior.ColorIndex = ColorYellow
YellowSw = True
Else
Range(Cells(TestRow2, Col1), Cells(TestRow2, Col2)).Interior.ColorIndex = xlNone
YellowSw = False
End If

' Red Test-----------------------
If (Not GreenSw) And (Not YellowSw) Then
Range(Cells(TestRow3, Col1), Cells(TestRow3, Col2)).Interior.ColorIndex = ColorRed
Else
Range(Cells(TestRow3, Col1), Cells(TestRow3, Col2)).Interior.ColorIndex = xlNone
End If
'
End Sub

'-------End Copy----------------
 
Back
Top