VBA code - color format routine

[xlwho]

Hi all,

After doing a search and reading through all of the posts on workarounds for applying more than 3 conditional formats, I still can't get a working solution to my application. There must be something simple I'm missing, but I can't figure it out.

My workbook contains two sheets, the first sheet accommodates pasted data from an outside app. The second sheet grabs data from the first and lays it out to match an Avery label format (30 labels...3 across and 10 down) for printing. Each label area is made up of a range of 9 cells, for example, the first label will print out the data contained in cells A1:C3. There is a column and a row separating each label, so the next label to the right is made up data shown in cells E1:G3, etc.

The traditional conditional formatting for each label cell range is based on the day of the week listed in the right-most upper cell of each label range, so for the first label (cells A1:c3), the 3 conditional format formulas for all 9 cells are:

1. =weekday(C1)=2, then font color = red
2. =weekday(C1)=3, then font color = blue
3. =weekday(C1)=4, then font color = green

I need two more conditional formats for Thursday and Friday. Granted, I could always have the default color be for one of these, but I'm still short one conditional format. I tried converting some of the existing VBA code out there to accommodate for this, but could not get it to work. I seem to be having problems applying the code to all 30 cell ranges:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Num As Long
Dim rng As Range
Dim vRngInput As Variant

Set vRngInput = Intersect(Target, Range("A1:C3"))
If vRngInput Is Nothing Then Exit Sub
For Each rng In vRngInput
'Determine the color
Select Case rng.Value
Case Is = Weekday(C1) = 2: Num = 3 'red
Case Weekday(C1) = 3: Num = 5 'blue
Case Weekday(C1) = 4: Num = 10 'green
Case Weekday(C1) = 5: Num = 7 'magenta
Case Weekday(C1) = 6: Num = 1 'black
End Select
'Apply the color
rng.Font.ColorIndex = Num
Next rng

Set vRngInput = Intersect(Target, Range("E1:G3"))
If vRngInput Is Nothing Then Exit Sub
For Each rng In vRngInput
'Determine the color
Select Case rng.Value
Case Is = Weekday(G1) = 2: Num = 3 'red
Case Weekday(G1) = 3: Num = 5 'blue
Case Weekday(G1) = 4: Num = 10 'green
Case Weekday(G1) = 5: Num = 7 'magenta
Case Weekday(G1) = 6: Num = 1 'black
End Select
'Apply the color
rng.Font.ColorIndex = Num
Next rng

Set vRngInput = Intersect(Target, Range("I1:K3"))
If vRngInput Is Nothing Then Exit Sub
For Each rng In vRngInput
'Determine the color
Select Case rng.Value
Case Is = Weekday(K1) = 2: Num = 3 'red
Case Weekday(K1) = 3: Num = 5 'blue
Case Weekday(K1) = 4: Num = 10 'green
Case Weekday(K1) = 5: Num = 7 'magenta
Case Weekday(K1) = 6: Num = 1 'black
End Select
'Apply the color
rng.Font.ColorIndex = Num
Next rng

Set vRngInput = Intersect(Target, Range("A5:C7"))
If vRngInput Is Nothing Then Exit Sub
For Each rng In vRngInput
'Determine the color
Select Case rng.Value
Case Is = Weekday(C5) = 2: Num = 3 'red
Case Weekday(C5) = 3: Num = 5 'blue
Case Weekday(C5) = 4: Num = 10 'green
Case Weekday(C5) = 5: Num = 7 'magenta
Case Weekday(C5) = 6: Num = 1 'black
End Select
'Apply the color
rng.Font.ColorIndex = Num
Next rng

...I keep going untill I have all 30 label ranges layed out but it's not working right. What can I do to get this to work?

Thanks!

[mangesh_yadav]

Try:

Set vRngInput = Intersect(Target, Range("A1:C3"))
If vRngInput Is Nothing Then Exit Sub
For Each rng In vRngInput
'Determine the color
Select Case WorksheetFunction.Weekday(rng)
Case 2: Num = 3 'red
Case 3: Num = 5 'blue
Case 4: Num = 10 'green
Case 5: Num = 7 'magenta
Case 6: Num = 1 'black
Case Else: ' Other values.
End Select
'Apply the color
rng.Font.ColorIndex = Num
Next rng



Mangesh

[xlwho]

Thanks for the reply! Each block of 9 cells only has a date field at the upper right cell, the other fields are text or numbers. Also, is there a way to loop through the 30 conditions (maybe using an offset formula for the date fields and blocks of 9 cells to be formatted) instead of re-doing almost identical code for each label? Thanks!

[xlwho]

Well, I figured out a way to solve this with a macro, but I get a run-time error 13, "type mismatch" prompt if any cells are left blank. Is there an easy way to skip to the next block of code if the MyDate value in any particular block is blank?

Sub Format_All()

'
' Format_All Macro
' Macro recorded 11/2/2006 by KJP
'
Dim MyDate As Long

Range("A1:K39").Select
Selection.Font.ColorIndex = 1 'black

MyDate = Range("C1")
If Weekday(MyDate) = 2 Then
Range("A1:C3").Select
Selection.Font.ColorIndex = 3 'red

ElseIf Weekday(MyDate) = 3 Then
Range("A1:C3").Select
Selection.Font.ColorIndex = 5 'blue

ElseIf Weekday(MyDate) = 4 Then
Range("A1:C3").Select
Selection.Font.ColorIndex = 10 'dark green

ElseIf Weekday(MyDate) = 5 Then
Range("A1:C3").Select
Selection.Font.ColorIndex = 7 'pink

Else 'nothing - leave black
End If

MyDate = Range("G1")
If Weekday(MyDate) = 2 Then
Range("E1:G3").Select
Selection.Font.ColorIndex = 3

ElseIf Weekday(MyDate) = 3 Then
Range("E1:G3").Select
Selection.Font.ColorIndex = 5 'blue

ElseIf Weekday(MyDate) = 4 Then
Range("E1:G3").Select
Selection.Font.ColorIndex = 10 'dark green

ElseIf Weekday(MyDate) = 5 Then
Range("E1:G3").Select
Selection.Font.ColorIndex = 7 'pink

Else 'nothing - leave black
End If
.
.
...this continues for all 30 label ranges..
.
.
. MyDate = Range("K37")
If Weekday(MyDate) = 2 Then
Range("I37:K39").Select
Selection.Font.ColorIndex = 33 'sky blue

ElseIf Weekday(MyDate) = 3 Then
Range("I37:K39").Select
Selection.Font.ColorIndex = 13 'violet

ElseIf Weekday(MyDate) = 4 Then
Range("I37:K39").Select
Selection.Font.ColorIndex = 53 'brown

ElseIf Weekday(MyDate) = 5 Then
Range("I37:K39").Select
Selection.Font.ColorIndex = 4 'lt green

Else 'nothing - leave grey
End If

End Sub

[Mallycat]

The problem is that if it is blank, it is not data type LONG. So you need to trap for that before the code MyDate = Range("C1")

You could try adding

Please Login or Register  to view this content.

This will continue the code if an error it hit. The problem with this approach is that it can hide other errrors without you knowing.

Also you could tidy up your code quite a bit. If I were you, I would use a Select Case routine rather than all those if statements. The If statements all have to be evaluated one by one, where as a select case statement only gets evaluated once. Also you can combine some of the lines

This
Range("I37:K39").Select
Selection.Font.ColorIndex = 53 'brown

is better as this

Range("I37:K39").Font.ColorIndex = 53 'brown

EDIT
Also, you could combine all of the tests and formats

ie
Case Weekday(MyDate) = 3
Range("I37:K39").Font.ColorIndex = 13 'violet
Range("E1:G3").Font.ColorIndex = 5 'blue
Case Weekday(MyDate)= 4
yada yada etc



Matt

[xlwho]

Thanks for the tips...I'm not really any good with coding, but I found a fix that seems to work with the code I had. Your comment about mydate as long helped a lot. I'm still curious about looping through the 30 sets of conditions instead of laying each section out the way I did, but for now I'm just happy that it works! Here's the working method:

Please Login or Register  to view this content.

I'm guessing that if I used two lists, I could somehow use a loop to repeat the code, but I don't know how to do this. The first list would contain the 30 cells with dates to check against, and the second list contains the ranges of the associated cells to format the font color depending on the day of the week of the value in list 1.

not sure how to define lists, something like:
list_1 = "C1", "G1", "K1", "C5", "G5", "K5".... 'continue for all 30 dates cells
list_2 = "A1:C3","E1:G3", "I1:K3", "A5:C7", "E5:G7", "I5:K7"... 'continue for all label ranges

Then set up a loop for 1 to 30, using two defined variables for each date and cell range from the lists. Just don't know how to write the code. I'm learning more each day though =)

[mangesh_yadav]

You are probably looking for:


-----------
Private Sub CommandButton1_Click()

' define your list here, add all 30 here
' actually there is a pattern in your requirement, and you actually don't require to define a list
' your column 2 is Range(Range("<column1>"), Range("<column1>").Offset(2,-2)).Address

Dim myArr
myArr = Array(Array("C1", "A1:C3"), _
Array("G1", "E1:G3"), _
Array("K1", "I1:K3"))



For i = 0 To UBound(myArr)

If Range(myArr(i)(0)) <> "" Then

Select Case WorksheetFunction.Weekday(Range(myArr(i)(0)))
Case 2: Num = 3 'red
Case 3: Num = 5 'blue
Case 4: Num = 10 'green
Case 5: Num = 7 'magenta
Case 6: Num = 1 'black
Case Else: 'Other values.
End Select

'Apply the color
Range(myArr(i)(1)).Font.ColorIndex = Num


End If

Next i

End Sub

-----------