Complicated VBA Conditional Formatting

L

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
 
T

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
 
L

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

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

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

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
 
L

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
 
T

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
 
T

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
 
L

Leslie

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

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

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

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

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

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
 
T

Toppers

Sorry .. place after Thisworkbook. ....

Toppers said:
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
 
L

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
 
L

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.
 

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

Top