PDA

View Full Version : Conditional Formatting using VBA



Andreita
09-09-2008, 11:11 AM
Hi!
I am so happy I found this forum, I have learned a lot by reading the posts.
I am not very computer savvy, much less with VBA for excel. However through my reading I have come to the conclusion that the only way to have more than 3 conditional formatting conditions is through VBA.
I am using Excel 2003 and this is my scenario:
I have a set of categories as rows, and different deliverables for each category as colums. I want to track the status of each deliverable with color coding.
For example, I want the cells where I enter 1 to be white font & white background, 2=Red, 3= Orange, 4= Yellow and 5=Green. I also have a formula that calculates the average of my rankings to give me an overview of the task's completion. I would like to have this cells with the same format, so they turn the color respective to the number the formula returns.

I found the following code on another threat in this forum, however, I have no idea what anything means and therefore cannot modify it to fit my needs.

Any and all help is greatly appreciated and needed!!!!

Thanks a lot in advance!
Andrea


Option Compare Text 'A=a, B=b, ... Z=z
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Cell As Range
Dim Rng1 As Range

On Error Resume Next
Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error Goto 0
If Rng1 Is Nothing Then
Set Rng1 = Range(Target.Address)
Else
Set Rng1 = Union(Range(Target.Address), Rng1)
End If
For Each Cell In Rng1
Select Case Cell.Value
Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
Case "Tom", "Joe", "Paul"
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case "Smith", "Jones"
Cell.Interior.ColorIndex = 4
Cell.Font.Bold = True
Case 1, 3, 7, 9
Cell.Interior.ColorIndex = 5
Cell.Font.Bold = True
Case 10 To 25
Cell.Interior.ColorIndex = 6
Cell.Font.Bold = True
Case 26 To 99
Cell.Interior.ColorIndex = 7
Cell.Font.Bold = True
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select
Next

End Sub

Kenneth Hobs
09-09-2008, 12:55 PM
That code is a sheet's Change event so paste it by right clicking the sheet's tab, View Code and paste.

Delete all of the Case lines except for one and set it as you want. You can then copy it and change the font and interior colorindexes to match your specific cases.

Select the Insert menu and insert a Module and paste this code. It makes reference index colors a bit easier.
'by xld, http://vbaexpress.com/forum/showthread.php?t=22084
Public Enum xlColorIndex
xlCIBlack = 1
xlCIWhite = 2
xlCIRed = 3
xlCIBrightGreen = 4
xlCIBlue = 5
xlCIYellow = 6
xlCIPink = 7
xlCITurquoise = 8
xlCIDarkRed = 9
xlCIGreen = 10
xlCIDarkBlue = 11
xlCIDarkYellow = 12
xlCIViolet = 13
xlCITeal = 14
xlCIGray25 = 15
xlCIGray50 = 16
xlCIPeriwinkle = 17 '-----------------------------
xlCIPlum = 18 ' chart colours
xlCIIvory = 19 '
xlCILightTurquoiseChart = 20 '
xlCIDarkPurpleChart = 21 '
xlCICoralChart = 22 '
xlCIOceanBlueChart = 23 '
xlCIIceBlueChart = 24 '
xlCIDarkBlueChart = 25 '
xlCIPinkChart = 26 '
xlCIYellowChart = 27 '
xlCITurquoiseChart = 28 '
xlCIVioletChart = 29 '
xlCIDarkRedChart = 30 '
xlCITealChart = 31 '
xlCIBlueChart = 32 '-----------------------------
xlCISkyBlue = 33
xlCILightGreen = 35
xlCILightYellow = 36
xlCIPaleBlue = 37
xlCIRose = 38
xlCILavender = 39
xlCITan = 40
xlCILightBlue = 41
xlCIAqua = 42
xlCILime = 43
xlCIGold = 44
xlCILightOrange = 45
xlCIOrange = 46
xlCIBlueGray = 47
xlCIGray40 = 48
xlCIDarkTeal = 49
xlCISeaGreen = 50
xlCIDarkGreen = 51
xlCIBrown = 53
xlCIIndigo = 55
xlCIGray80 = 56
End Enum



For the sheet's Change event
e.g.
Case 2
Cell.Interior.ColorIndex = xlCIRed 'xlCIRed = 3
Cell.Font.ColorIndex = xlCIWhite 'xlCIWhite = 2
Case Else
Cell.Interior.ColorIndex = xlColorIndexNone
Cell.Font.ColorIndex = xlCIBlack


Use xlColorIndexNone for no color index.

Maui_Jim
09-09-2008, 01:15 PM
If you prefer to use the same type of VBA format as you provided, I believe this code will provide the cell coloring you requested.

To add this code:
> Right-click on the Sheet Tab (e.g. Sheet1)
> Select the ?View Code? option
- A VBA window will appear
> Copy the code below and Paste into the VBA window
> Close the VBA Editor (Alt + Q)




Private Sub Worksheet_Change(ByVal Target As Range)

Dim Cell As Range
Dim Rng1 As Range

On Error Resume Next
Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0
If Rng1 Is Nothing Then
Set Rng1 = Range(Target.Address)
Else
Set Rng1 = Union(Range(Target.Address), Rng1)
End If
For Each Cell In Rng1
Select Case Cell.Value
Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
Case 2
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case 3
Cell.Interior.ColorIndex = 45
Cell.Font.Bold = True
Case 4
Cell.Interior.ColorIndex = 6
Cell.Font.Bold = True
Case 5
Cell.Interior.ColorIndex = 4
Cell.Font.Bold = True
Case 1
Cell.Interior.ColorIndex = -4142
Cell.Font.ColorIndex = 2
Cell.Font.Bold = True
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select

Next

End Sub


Now, each time you enter a 1, 2, 3, 4, or 5 on this particular worksheet, the cell color will change. Your ranking formula cells will also change if the result is 1-5 (even formatted with decimals if needed).


Hope this helps,
Jim

Andreita
09-09-2008, 02:24 PM
Thank you Kenneth & Jim. :)
It works very nicely.
The only thing that is happening is that it is giving me an error when I try to put the average formula on the cells that do not have the numbers yet (becuase the formula has a zero divisor)
This is the line where the error is: Case vbNullString
Is there any way I can get arround this?

Thanks again.
Andrea

Bob Phillips
09-09-2008, 02:47 PM
Try testing it first for an error



If IsError(Target.Value) Then Exit sub

Maui_Jim
09-09-2008, 04:47 PM
Andrea,

Of course, xld is right on it. Not exiting the sub if an error is encountered is my oversight. In further testing I also found that I needed to add the "black" font color in every case. This will prevent the issue where there was a 1 entered into the cell from retaining it's "white" font.

Finally, since it appears you will be using fractions of numbers, I modified the code to include decimals (e.g 1 To 1.99).

Try pasting this new code in the same manner described in the previous post.


Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
On Error Resume Next
Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0
If Rng1 Is Nothing Then
Set Rng1 = Range(Target.Address)
Else
Set Rng1 = Union(Range(Target.Address), Rng1)
End If
For Each Cell In Rng1
If IsError(Target.Value) Then Exit Sub
Select Case Cell.Value
Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.ColorIndex = 0
Cell.Font.Bold = False
Case 2# To 2.99
Cell.Interior.ColorIndex = 3
Cell.Font.ColorIndex = 0
Cell.Font.Bold = True
Case 3# To 3.99
Cell.Interior.ColorIndex = 45
Cell.Font.ColorIndex = 0
Cell.Font.Bold = True
Case 4# To 4.99
Cell.Interior.ColorIndex = 6
Cell.Font.ColorIndex = 0
Cell.Font.Bold = True
Case 5# To 5.99
Cell.Interior.ColorIndex = 4
Cell.Font.ColorIndex = 0
Cell.Font.Bold = True
Case 1# To 1.99
Cell.Interior.ColorIndex = -4142
Cell.Font.ColorIndex = 2
Cell.Font.Bold = True
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.ColorIndex = 0
Cell.Font.Bold = False
End Select
Next
End Sub


Regards,
Jim

Bob Phillips
09-10-2008, 12:22 AM
In this code, the lines



For Each Cell In Rng1
If IsError(Target.Value) Then Exit Sub


should be



For Each Cell In Rng1
If IsError(Cell.Value) Then Next Cell

Andreita
09-10-2008, 07:45 AM
Thanks..
Another thing that is coming up. When I write the formula I need to use.
"=average(F3:F5) for example. It sends me to debug something and it shows the line "Case vbNullString" in yellow.. How can I fix this??
Thanks again,
Andrea

Bob Phillips
09-10-2008, 08:15 AM
Maybe test for a formula before doing anything?

Kenneth Hobs
09-10-2008, 08:35 AM
Not sure why cell.value would ever return an error. If it did, then you can Goto or Resume to the next Next as shown below. Another method is to use "OnError Goto nextcell" before the For and "OnError Goto 0" after the Next.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
On Error Resume Next
Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0
If Rng1 Is Nothing Then
Set Rng1 = Range(Target.Address)
Else
Set Rng1 = Union(Range(Target.Address), Rng1)
End If
For Each Cell In Rng1
If IsError(Cell.Value) Then Resume nextcell
Select Case Cell.Value
Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.ColorIndex = 0
Cell.Font.Bold = False
Case 2# To 2.99
Cell.Interior.ColorIndex = 3
Cell.Font.ColorIndex = 0
Cell.Font.Bold = True
Case 3# To 3.99
Cell.Interior.ColorIndex = 45
Cell.Font.ColorIndex = 0
Cell.Font.Bold = True
Case 4# To 4.99
Cell.Interior.ColorIndex = 6
Cell.Font.ColorIndex = 0
Cell.Font.Bold = True
Case 5# To 5.99
Cell.Interior.ColorIndex = 4
Cell.Font.ColorIndex = 0
Cell.Font.Bold = True
Case 1# To 1.99
Cell.Interior.ColorIndex = -4142
Cell.Font.ColorIndex = 2
Cell.Font.Bold = True
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.ColorIndex = 0
Cell.Font.Bold = False
End Select
nextcell:
Next Cell
End Sub

Bob Phillips
09-10-2008, 09:47 AM
Not sure why cell.value would ever return an error.

The cell had an error, such as #DIV/0

Andreita
09-10-2008, 01:24 PM
Yes, xld.. That is why it is giving me the error, because I have the formula for the averages but do no have the numbers yet.
Thanks for the help to both of you.. However it still gives me the error when I write the formula down.

I am copying the code exactly like I have it..I have no idea what is causing this.. It now highlights what I have put in red below.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
On Error Resume Next
Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0
If Rng1 Is Nothing Then
Set Rng1 = Range(Target.Address)
Else
Set Rng1 = Union(Range(Target.Address), Rng1)
End If
For Each Cell In Rng1
If IsError(Cell.Value) Then Resume nextcell
Select Case Cell.Value
Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.ColorIndex = 0
Case 1.5 To 2.4
Cell.Interior.ColorIndex = 3
Cell.Font.ColorIndex = 3
Case 2.5 To 3.4
Cell.Interior.ColorIndex = 45
Cell.Font.ColorIndex = 45
Case 3.5 To 4.4
Cell.Interior.ColorIndex = 6
Cell.Font.ColorIndex = 6
Case 4.5 To 5.99
Cell.Interior.ColorIndex = 4
Cell.Font.ColorIndex = 4
Case 1# To 1.4
Cell.Interior.ColorIndex = 2
Cell.Font.ColorIndex = 2
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.ColorIndex = 0
End Select
nextcell:
Next Cell
End Sub

Thanks a million..
Andrea

Kenneth Hobs
09-10-2008, 01:37 PM
The better route is as I explained using On Error. I usually add error code to my formulas so I seldom need this kind of thing.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
On Error Resume Next
Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0
If Rng1 Is Nothing Then
Set Rng1 = Range(Target.Address)
Else
Set Rng1 = Union(Range(Target.Address), Rng1)
End If
On Error GoTo nextcell
For Each Cell In Rng1
Select Case Cell.Value
Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.ColorIndex = 0
Case 1.5 To 2.4
Cell.Interior.ColorIndex = 3
Cell.Font.ColorIndex = 3
Case 2.5 To 3.4
Cell.Interior.ColorIndex = 45
Cell.Font.ColorIndex = 45
Case 3.5 To 4.4
Cell.Interior.ColorIndex = 6
Cell.Font.ColorIndex = 6
Case 4.5 To 5.99
Cell.Interior.ColorIndex = 4
Cell.Font.ColorIndex = 4
Case 1# To 1.4
Cell.Interior.ColorIndex = 2
Cell.Font.ColorIndex = 2
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.ColorIndex = 0
End Select
nextcell:
Next Cell
On Error GoTo 0
End Sub

Andreita
09-10-2008, 01:48 PM
This is awesome!!!! THANKS.. No more errors with the formula!!!
I appreciate you taking the time to help me!
Thank you both sooo much for everything!
-Andrea :)