Complicated VBA Conditional Formatting

[Leslie]

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

 

[Toppers]

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]

Thanks very much. I inserted the code but rec'd the error "Run-Time error
1004 Application defined or object defined error" Any ideas. Thanks again
for your help in figuring this out.

 

[Leslie]

Ignore my last note. I pasted it to the wrong worksheet. I pasted it into
the correct worksheet and it is giving me a message "Run-Time error 9,
subscript out of range. Any ideas? Thanks again.

 

[Leslie]

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]

Hi,
These are the "named" ranges I mentioned. You can try changing to:

ncol=Application.Match(Range("a2"),Range("F3:Q3"),0)+5

This avoids using named ranges.

On re-reading your note I didn't check colum A for a 4 digits/Letters; Try
the above a get the code working and I will look at adding the required test.
Can I simply test that column A has field of length 4, irrespctive of whether
it is numbers/letters or amixture?

HTH

 

[Leslie]

Re: Col. A yes for field length of four. Also, I defined the Ranges so I
think that is okay now but I am getting a Type Mismatch error 13. Any ideas?
Thanks. Here is my code:

Sub CFormat()

Dim rng As Range, cell As Range
Dim ncol As Integer, lrow As Long
Dim pcnt As Double, divisor As Double

'Ace is sheet name
ThisWorkbook.Worksheets("Ace").Activate

' 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(20, 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 percentage
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

 

[Toppers]

Hi,

Type mismatch suggests invalid data and I didn't put any check in for
valid data; which statement is it going wrong on?

You can "step through" the macro by opening the code and with the cursor
somewhere in the code, and press the F8 button. This will go through an
instruction at a time. You could add statements to show the variable values-
an eay way is to use:

msgbox ncol
msgbox lrow
msgbox divisor
msgbox cell

placed at appropriate points in the code.

If you alter the window size of the VB code you can look at the data as it
executes.


I see (in you code) your data starts at row 20 not 9.


The code below tests for column A having a field of length 4:

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

End Sub

 

[Toppers]

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]

I think it stops when it hits a #DIV/0 on the spreadsheet. Could that be it.
How do I fix that? Thanks.

 

[Toppers]

Hi,
Can you divide by zero in your situation i.e. values in row 5 should
not be zero ? See my prvoius reply about blank data.

 

[Leslie]

It is stopping when it hits a #DIV/0 but once we have column A included in
the code then that won't happen but there will be blanks.

 

[Leslie]

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

 

[Toppers]

I am still confused as I thought we were dividing by row 5 which I wouldn't
expect to be zero. However, I appreciate the data in row 9 (or 20) onwards
could have blanks and that does cause the type mismatch error. Again I have
put the test for column A on the data in row 9 onwards not on row 5!


Hopefully you can now sort it out.

 

[Toppers]

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

 

[Leslie]

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]

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

 

[Toppers]

Sorry .. place after Thisworkbook. ....

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

 

[livebird]

I ran the code as listed and also received the type mismatch error.

I then checked and made sure that my month headers coincided with th
range that was set.

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

Once I made sure that Jan was on column F, everything flowed well an
the appropriate values were highlighted

 

[Leslie]

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.