Thanks again. That did fix it even though row 102 was not the last non-blank
cell in the current month. Regarding the clearing color with the code we are
using it clears out other coloring I have in certain rows. Is there a way to
limit the clearing of colors to just what we coded?

"Toppers" wrote:

Becaues (I am "guessing") row 102 is the last non-blank cell in the current
month; this what lrowl calculates. If you want to use column A as the
delimeteri .e column A is always the longest, then change ncol in the lrow
statement to 1 i.e.

lrow = Cells(Rows.Count, 1).End(xlUp).Row.

You could then modify the code to clear the colours as below and move AFTER
the lrow line.

Range("F9:Q" & lrow).Select
Selection.Interior.ColorIndex = xlNone


"Leslie" wrote:

Yeah! Its working BUT, another But, Very oddly it colored all the blank cells
up to row 102 and then just stopped. I can't imagine why that is.

"Toppers" wrote:

Add these lines after End Select

Else
cell.Select
Selection.Interior.ColorIndex = 3


i.e.

End Select
* Else
* cell.Select
* Selection.Interior.ColorIndex = 3
End If

"Leslie" wrote:

Thanks its working great. The only thing that is not working is if the cell
is empty or blank it should also have a background color of red. I've been
trying to figure this out but no luck so far. Thanks again for all your
help.

"Toppers" wrote:

Hi,
The simplest way would be to clear ALL months at the beginning of
the macro and just re-populate the current month.

Range("F9:Q100").Select <=== change to 100 to whatever you think the max
roes are going to be.
Selection.Interior.ColorIndex = xlNone ' Clears the colours

Place this code at the start of the macro - after DIM statements.

HTH


"Leslie" wrote:

Thanks so much for all your help that was so tricky for me. May I ask one
more question. I tried it out and everything works great but I think it is
missing something. Once July comes or any month thereafter I want it to
clear out the background colors from the previous month and only have the
current month highlighted. Is that possible to do?

"Toppers" wrote:

Check the END IF are all there! It works OK on my machine!

"Leslie" wrote:

It doesn't like the "Next Cell" at the bottom of the code. Thanks.

"Toppers" wrote:

Hi again,
You will get your error message if the cell is blank so I
have added a test for cell value being a number.

HTH

Sub CFormat()
'
Dim rng As Range, cell As Range
Dim ncol As Integer, lrow As Long
Dim pcnt As Double, divisor As Double

ThisWorkbook.Worksheets("Sheet1").Activate ' <=== Change to your w/sheet
' Find column for current Month (add 5 to start in colum F onwards)
ncol = Application.Match(Range("A2"), Range("F3:q3"), 0) + 5

' Find last row of data in current month column
lrow = Cells(Rows.Count, ncol).End(xlUp).Row

' Set range to cells for current month starting row 9
Set rng = Range(Cells(9, ncol), Cells(lrow, ncol))

' Set Divisor for current month
divisor = Cells(5, ncol)

' Loop through all cells in range
For Each cell In rng
' Check length of cell in column A
If Len(cell.Offset(0, -(ncol - 1))) = 4 Then
' Calculate perecentage
If Application.IsNumber(cell) Then ' Is this cell a number ?
pcnt = (cell / divisor) * 100
cell.Select
' Set colorindex based on percentage
Select Case pcnt
Case Is 100
Selection.Interior.ColorIndex = 4
Case Is = 90
Selection.Interior.ColorIndex = 35
Case Is = 80
Selection.Interior.ColorIndex = 36
Case Is = 70
Selection.Interior.ColorIndex = 7
Case Is = 1
Selection.Interior.ColorIndex = 54
Case Else
Selection.Interior.ColorIndex = 3
End Select
End If
End If
Next cell

End Sub


"Leslie" wrote:

Okay, I've confused myself. The run-time error is 1004 after all. I think
it is stuck at:

ncol = Application.Match(Range("CurMonth"), Range("HdrMonths"), 0) + 5

but since I am new to this VBA stuff I most likely am wrong. Does it have
something to do with "ncol". Thanks.

"Toppers" wrote:

Hi,
Try this: insert this code into a general module.

I have defined the cell A2 as a named range called "CurMonth" and the month
headers as a range "HdrMonths".

Sub CFormat()
'
Dim rng As Range, cell As Range
Dim ncol As Integer, lrow As Long
Dim pcnt As Double, divisor As Double

Thisworkbook.Worksheets("Sheet1").activate <=== Change to your w/sheet

' Find column for current Month (add 5 to start in colum F onwards)
ncol = Application.Match(Range("CurMonth"), Range("HdrMonths"), 0) + 5

' Find last row of data in current month column
lrow = Cells(Rows.Count, ncol).End(xlUp).Row

' Set range to cells for current month starting row 9
Set rng = Range(Cells(9, ncol), Cells(lrow, ncol))

' Set Divisor for current month
divisor = Cells(5, ncol)

' Loop through all cells in range
For Each cell In rng
' Calculate perecentage
pcnt = (cell / divisor) * 100
cell.Select
' Set colorindex based on percentage
Select Case pcnt
Case Is 100
Selection.Interior.ColorIndex = 4
Case Is = 90
Selection.Interior.ColorIndex = 35
Case Is = 80
Selection.Interior.ColorIndex = 36
Case Is = 70
Selection.Interior.ColorIndex = 7
Case Is = 1
Selection.Interior.ColorIndex = 54
Case Else
Selection.Interior.ColorIndex = 3
End Select
Next cell

End Sub


HTH

"Leslie" wrote:

First, the formatting will only highlight certain cells in a column when the
column header in Row 3 is the current month which is tied to A2 which is
=Text(now(),"mmm"). Second, only those cells in rows in which Column A has
four digit letters or numbers will be highlighted. What I need is if, for
example, "Col F Row 9" / "Col F Row 5" = 200% then the cell background will
be shaded bright green. Row 5 is static and used as the divisor for all. The
conditions a if the percent is 100.1% or greater then background of cell
is bright green, if percent is 90-100% then light green, if percent is
80-89.9% than light yellow, if percent is 70-79.9% than pink, if 1-69.9% then
purple, if percent is 0 or blank then red. The columns that contain the data
are columns F-P. Is there any way to automate this process. Thanks in
advance. I am very new to VBA.

Col F Col G Col H Col I Col J Col k Col L
Row 3 Jan Feb Mar Apr May Jun Jly

Row 5 $500 $500 $500 $750 $750 $750 $1,000

Row 9 $1000 $750 $500 $0 $1500 $900 $500
Many Rows just like Row 9