PDA

View Full Version : Conditional formatting in vba (more than three) select values from a worksheet



jonscrut
07-03-2008, 11:00 PM
Hi,

I don't know much about VBA, but I took the code from DRJ's post (I can't post a link but it's the KB article called " Conditional Formatting (More Than Three)") and added some other stuff from another sample excel file I found on the web which enables me to set the values for the VBA conditional formatting on one of the worksheets, which is great because I don't have to go into the code eveytime I want to change the colours or the values:

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

Private Sub Worksheet_Change(ByVal Target 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

Dim cl As Range
For Each cl In Rng1
On Error Resume Next
cl.EntireRow.Interior.ColorIndex = _
Application.WorksheetFunction.VLookup(cl.Value, _
ThisWorkbook.Sheets("CFControl").Range("rngColors"), 2, False)
If Err.Number <> 0 Then
cl.Interior.ColorIndex = xlNone
End If
Next cl

End Sub
I have a worksheet called "CFControl" and the code does a Vlookup on two columns, headed 'Value' and 'ColorIndex'.

For example I have instances of the word "draft" coloured red and "completed" green.

My problems are this:

1) I want the range to be anywhere on any worksheet. At the moment it only works when I apply it one particular worksheet

2) The range is weird. As soon as I enter data in another cell on the same ine, it removes the formatting. I would like it to leave the formatting if it fines the word "draft" in any cell on a line.

3) Is there a way of setting the range in the CFControl worksheet so that the code goes there to find out which column it should look in (that would solve the range problem) so I could have a column that says "worksheet column to search in". type B for column B and then the VBA code would only carry search the conditions in column B.

4) It crashes when you try and delete a lot of stuff when I had it set to entirerow.interior.colorindex rather than just interior.colorindex.

Example spreadsheet attached

Bob Phillips
07-04-2008, 12:40 AM
1)



Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng1 As Range
Dim LookupVal As Variant


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

Dim cl As Range
For Each cl In Rng1
On Error Resume Next
LookupVal = cl.Value
If Not IsNumeric(cl.Value) Then LookupVal = """" & cl.Value & """"
cl.EntireRow.Interior.ColorIndex = _
Me.Evaluate("VLOOKUP(" & LookupVal & ",rngColors, 2, False)")
If Err.Number <> 0 Then
cl.Interior.ColorIndex = xlNone
End If
Next cl

End Sub


2) This is because of the way that the code is written. It examines the cell and if that particular one that isn't in the lookup table, it clears it regardless.

If you want to test for draft anywhere, you need to add it, but what about other colours/values?

3) You could add a third column in the rngColors range that designates the column, yes.

4) ?????

Bob Phillips
07-04-2008, 12:48 AM
This should address the rest



Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng1 As Range
Dim LookupVal As Variant
Dim ColIndex As Long

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

Dim cl As Range
For Each cl In Rng1

On Error Resume Next
LookupVal = cl.Value
If Not IsNumeric(cl.Value) Then LookupVal = """" & cl.Value & """"
ColIndex = Me.Evaluate("VLOOKUP(" & LookupVal & ",rngColors, 3, False)")
If Me.Cells(cl.Row, ColIndex).Value Then
cl.EntireRow.Interior.ColorIndex = _
Me.Evaluate("VLOOKUP(" & LookupVal & ",rngColors,2, False)")
Else
cl.EntireRow.Interior.ColorIndex = xlNone
End If
Next cl

End Sub