Visual Basic programming in Excel for conditional formatting

D

Doo0592

Hi all,

I am trying to create a spreadsheet that will highlight certain
conditions when they match. So far I have what is below. I need to add
another case that will highlight the row when a date passes (ie,
todays()). I would like it to highlight interior red with white bold
font. And how do i get this code to act on multiple rows?

Any help appreciated :)

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "L3"


On Error GoTo ws_exit:
Application.EnableEvents = False
If Not Intersect(Target, Me.Range("B3:X3")) Is Nothing Then
With Target
Select Case .Value
Case "condition 1": Range("B3:X3").Interior.ColorIndex
= 15
Case "condition 2": Range("B3:X3").Interior.ColorIndex
= 35
Case "", "condition3":
Range("B3:X3").Interior.ColorIndex = 0
Case "condition 4": Range("B3:X3").Interior.ColorIndex
= 0
Case "condition 5": Range("B3:X3").Interior.ColorIndex
= 0


End Select
End With
End If


ws_exit:
Application.EnableEvents = True
End Sub
 
B

Bob Phillips

Is this what you mean

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "L3"

On Error GoTo ws_exit:
Application.EnableEvents = False
If Not Intersect(Target, Me.Range("B3:X3")) Is Nothing Then
With Target
If IsDate(.Value) Then
If .Value < Date Then
With Range("B3:X3")
.Font.ColorIndex = 2
.Interior.ColorIndex = 3
End With
End If
Else
Select Case .Value
Case "condition 1": _
Range("B3:X3").Interior.ColorIndex = 15
Case "condition 2": _
Range("B3:X3").Interior.ColorIndex = 35
Case "", "condition3": _
Range("B3:X3").Interior.ColorIndex = 0
Case "condition 4": _
Range("B3:X3").Interior.ColorIndex = 0
Case "condition 5": _
Range("B3:X3").Interior.ColorIndex = 0
End Select
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub



--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)
 
D

Doo0592

Nearly, I forgot to mention that the date will be entered in a
different cell from the conditions already set. It will be in M3. Can I
set IsDate to a variable that uses this cell as a reference? Or does
the date part have to be a separate procedure. Also, I am a nooby at VB
but I used to program a little on the BBC and I know basic JavaScript
so I understand most of the principles of programming in VB but not
all. I almost understand the code you have written but can you explain
the .value after IsDate? Is this where I can put my variable? Hope this
makes sense! :) Thanks for your help thou, I've been working on this
one for ages :(
 
B

Bob Phillips

I think that the code below is what you want.

As to the .Value, that is just testing the value of the Target cell. If you
notice, earlier there is a 'With Target' statement, and so any dot statement
(e.g. .Value) will refer to that object.

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo ws_exit:
Application.EnableEvents = False
With Target
If .Address = "$m$3" Then
If IsDate(.Value) Then
If .Value < Date Then
With Range("B3:X3")
.Font.ColorIndex = 2
.Interior.ColorIndex = 3
End With
End If
End If
ElseIf .Address = "$$3" Then
Select Case .Value
Case "condition 1": _
Range("B3:X3").Interior.ColorIndex = 15
Case "condition 2": _
Range("B3:X3").Interior.ColorIndex = 35
Case "", "condition3": _
Range("B3:X3").Interior.ColorIndex = 0
Case "condition 4": _
Range("B3:X3").Interior.ColorIndex = 0
Case "condition 5": _
Range("B3:X3").Interior.ColorIndex = 0
End Select
End If
End With

ws_exit:
Application.EnableEvents = True
End Sub


--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)
 
D

Doo0592

Hi Bob,

This nearly works but i don't think it's treating the date part as a
condition to evaluate. As this part runs first the (which is fine as
long as it doesn't override the second part) it's turning the cells/
fonts to white and red but they stay that way for the next part. Is
there a way we can assign the date value to a vairable to use in the
case statement?

Thanks
 
B

Bob Phillips

uh? Don't understand at all.

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)
 
D

Doo0592

Right,

I think I've cracked it! I gave up trying to write code that accounts
for all the conditions. Instead I have set Excel's conditional
formatting to evaluate for the date <= today (thanks for the code to
ignore blanks) and I have used VB to evaluate for the rest. It seems to
be working. The only flaw is that if you have entered a true value in
M3 and L3 and then delete the value in M3 it clears the formatting for
the whole row... because of the ignore blanks! I think I can live with
this but if you can think of a way around it I wouldn't say no! lol The
last and final thing I need to do is to get the VB code to evaluate for
rows 3:500. Can we use a for statement for this and, if so, how do we
write it?

Ta muchly Bob! :)
 
D

Doo0592

Lol, sorry Bob. Just read that other post back to myself! Your right it
doesn't make any sense :) NM. You can ignore those ramblings now!
 
B

Bob Phillips

If you want M3 to clear the CF when you clear its value, but not the rest of
the row, you need separate CF conditions for them. What do you currently
have?

When you want VB code (event code I presume)( to restrict its target range,
use something like the following

If Not Intersect(Target,Rows("3:500")) Is Nothing Then
'do your thing

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)
 
D

Doo0592

Ok... here's a quick explaination of what I am trying to achieve:

I work with cases that I have to track (sorry bout taking out the
actual conditions but this is for my work). L3 is the status of the
case. M3 is the date that the next action should be taken. I have the
cases hightlighting in green and grey on certain conditions through the
VB code and I have used Excel's conditional formatting box to higlight
the date. This works fine now apart from the conflict between using VB
code and Excel CF (not changing the cells back to normal if conditions
change). I will work this problem later I think.

This is the code I have for excuting the conditions on one row.

Private Sub Worksheet_Change(ByVal Target As Range)
Const ws_range As String = ("L3:L500")

On Error GoTo ws_exit:
Application.EnableEvents = False


If Not Intersect(Target, Me.Rows("3:500")) Is Nothing Then
With Target
Select Case .Value
Case "CONDITION 1": Range("B3:X3").Interior.ColorIndex
= 15
Case "CONDITION 2": Range("B3:X3").Interior.ColorIndex
= 35
Case "", "CONDITION 3":
Range("B3:X3").Interior.ColorIndex = 0
Case "CONDITION 4": Range("B3:X3").Interior.ColorIndex
= 0
Case "CONDITION 5": Range("B3:X3").Interior.ColorIndex
= 0
End Select
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

You will notice that most of the conditions have "blank" formatting. I
did this just so they would change back to normal if the "status" was
changed.

So this code evaluates the correct rows and I change the contents of
each row in column L but it will only change the interiors of B3:X3...
when if I change the contents of L4 it should change the interior of
B4:X4 etc.. Will I end up with lots of complicated Ifelse statements?
Gulp! :)

Does this make sense?
 
B

Bob Phillips

I think this is what you mean

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ws_exit:
Application.EnableEvents = False

If Not Intersect(Target, Me.Rows("3:500")) Is Nothing Then
With Target
Select Case .Value
Case "CONDITION 1":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 15
Case "CONDITION 2":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 35
Case "", "CONDITION 3":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 0
Case "CONDITION 4":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 0
Case "CONDITION 5":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 0
End Select
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

It might even be

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ws_exit:
Application.EnableEvents = False

If Not Intersect(Target, Me.Rows("3:500")) Is Nothing Then
With Target
Select Case .Value
Case "CONDITION 1":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 15
Case "CONDITION 2":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 35
Case Else:
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 0
End Select
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

The thing that worreis me about this is that it will paint B:X if CONDITION
1 is entered anywhere within the row. Seems a little odd.

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)
 
D

Doo0592

Yeah, I see what you mean. However, the conditions are picked from a
drop down list and are specific text strings so the chances of an end
user entering them in another cell should be minimal. But you know them
if they can bugger it up they will! Lol. I'll see how it goes, if
someone brings it up I'll change it but we spent so long figuring it
out I think I need to give it a rest for today. It's almost time for me
to go home :) Yay!
 
B

Bob Phillips

But if it was only specific cells why not test just them, as in an earlier
version.

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)
 
D

Doo0592

I'm just not sure how. Can you show me? That's why I was babbling about
Ifelse statements earlier btw :)

Doo
 
B

Bob Phillips

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "L3:L500"

On Error GoTo ws_exit:
Application.EnableEvents = False

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
With Target
Select Case .Value
Case "CONDITION 1":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 15
Case "CONDITION 2":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 35
Case "", "CONDITION 3":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 0
Case "CONDITION 4":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 0
Case "CONDITION 5":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 0
End Select
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

It might even be

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "L3:L500"

On Error GoTo ws_exit:
Application.EnableEvents = False

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
With Target
Select Case .Value
Case "CONDITION 1":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 15
Case "CONDITION 2":
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 35
Case Else:
Cells(.Row, 2).Resize(, 23).Interior.ColorIndex = 0
End Select
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub


--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)
 
D

Doo0592

Hey Bob,

Just thought you would like to know how it all turned out :) Here's my
finished code all tested and working! So proud! Thanks again, couldn't
have managed it without you! x

L3:L500 = status of case
K3:K500 = whether case is urgent
M3:M500 = if date has passed today to prompt action

Private Sub Worksheet_Change(ByVal Target As Range)


On Error GoTo ws_exit:
Application.EnableEvents = False

If Not Intersect(Target, Me.Range("L3:L500")) Is Nothing Then
With Target
Select Case .Value
Case "MISSING", "FOUND", "NO LONGER REQUIRED":
Cells(.row, 2).Resize(, 23).Interior.ColorIndex =
15
Case "AWAITING DELIVERY- STARS", "AWAITING DELIVERY-
FARIO", "AWAITING DELIVERY- OTHER":
Cells(.row, 2).Resize(, 23).Interior.ColorIndex =
35
Case Else:
Cells(.row, 2).Resize(, 23).Interior.ColorIndex = 0
End Select
End With
End If


If Not Intersect(Target, Me.Range("K3:K500")) Is Nothing Then
With Target
Select Case .Value
Case "Y":
Cells(.row, 2).Resize(, 22).Font.ColorIndex = 3
Cells(.row, 2).Resize(, 22).Font.Bold = True
Case "":
Cells(.row, 2).Resize(, 22).Font.ColorIndex = 1
Cells(.row, 2).Resize(, 22).Font.Bold = False
End Select
End With
End If

If Not Intersect(Target, Me.Range("M3:M500")) Is Nothing Then
With Target
Select Case .Value
Case Range("M3") <= Date:
Cells(row, 2).Resize(, 22).Interior.ColorIndex = 3
.Font.ColorIndex = 0
End Select
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub
 
B

Bob Phillips

Well done mate.

Just one small suggestion to stop unnecessary checking.

Instead of a structure like this

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo ws_exit:
Application.EnableEvents = False

If Not Intersect(Target, Me.Range("L3:L500")) Is Nothing Then
With Target
'do stuff
End With
End If

If Not Intersect(Target, Me.Range("K3:K500")) Is Nothing Then
With Target
'do stuff
End With
End If

If Not Intersect(Target, Me.Range("M3:M500")) Is Nothing Then
With Target
'do stuff
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

you c an use

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo ws_exit:
Application.EnableEvents = False

If Not Intersect(Target, Me.Range("L3:L500")) Is Nothing Then
With Target
'do stuff
End With
ElseIf Not Intersect(Target, Me.Range("K3:K500")) Is Nothing Then
With Target
'do stuff
End With
ElseIf Not Intersect(Target, Me.Range("M3:M500")) Is Nothing Then
With Target
'do stuff
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub


as it can only intersect one or another.

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)
 
D

Doo0592

I must have been hallucincating earlier cause now it's not working :(

Private Sub Worksheet_Change(ByVal Target As Range)


On Error GoTo ws_exit:
Application.EnableEvents = False


If Not Intersect(Target, Me.Range("L3:L500")) Is Nothing Then
With Target
Select Case .Value
Case "MISSING", "FOUND", "NO LONGER REQUIRED":
Cells(.row, 2).Resize(, 23).Interior.ColorIndex =
15
Case "AWAITING DELIVERY- STARS", "AWAITING DELIVERY-
FARIO", "AWAITING DELIVERY- OTHER":
Cells(.row, 2).Resize(, 23).Interior.ColorIndex =
35
Case Else:
Cells(.row, 2).Resize(, 23).Interior.ColorIndex = 0
End Select
End With



ElseIf Not Intersect(Target, Me.Range("K3:K500")) Is Nothing Then
With Target
Select Case .Value
Case "Y":
Cells(.row, 2).Resize(, 22).Font.ColorIndex = 3
Cells(.row, 2).Resize(, 22).Font.Bold = True
Case "":
Cells(.row, 2).Resize(, 22).Font.ColorIndex = 1
Cells(.row, 2).Resize(, 22).Font.Bold = False
End Select
End With


ElseIf Not Intersect(Target, Me.Range("M3:M500")) Is Nothing Then
With Target
Select Case .Value
Case Is <= Date
Cells(.row, 2).Resize(, 22).Interior.ColorIndex = 3
Cells(.row, 2).Resize(, 22).Font.ColorIndex = 0
End Select
End With
End If


ws_exit:
Application.EnableEvents = True
End Sub

Changed it to the ifelse statement as you suggested but (even before I
did this) the font has started turning black when i enter the date and
I need to enter code to stop it from evaluating the blank cell. Tried
adapting what you showed me earlier but to no avail...

tried: case is <= date and <> date but doesn't work.

I think it buggered up when I changed the cell reference from
range("M3") to case is to evaluate all the cells in M3:M500.
 
D

Doo0592

L3:L500 = status of case
K3:K500 = whether case is urgent
M3:M500 = if date has passed today to prompt action


Private Sub Worksheet_Change(ByVal Target As Range)


On Error GoTo ws_exit:
Application.EnableEvents = False

'Status of case condition
If Not Intersect(Target, Me.Range("L3:L500")) Is Nothing Then
With Target
Select Case .Value
Case "CONDITION 1":
Cells(.row, 2).Resize(, 23).Interior.ColorIndex =
15
Case "CONDITION 2":
Cells(.row, 2).Resize(, 23).Interior.ColorIndex =
35
Case Else:
Cells(.row, 2).Resize(, 23).Interior.ColorIndex = 0

End Select
End With
End If

'Urgent condition
If Not Intersect(Target, Me.Range("K3:K500")) Is Nothing Then
With Target
Select Case .Value
Case "Y":
Cells(.row, 2).Resize(, 22).Font.ColorIndex = 3
Cells(.row, 2).Resize(, 22).Font.Bold = True
Case "":
Cells(.row, 2).Resize(, 22).Font.ColorIndex = 1
Cells(.row, 2).Resize(, 22).Font.Bold = False
End Select
End With
End If

'Date condition
If Not Intersect(Target, Me.Range("M3:M500")) Is Nothing Then
With Target
Select Case .Value
Case Range("M3") <= Date:
Cells(.row, 2).Resize(, 22).Interior.ColorIndex = 3

.Font.ColorIndex = 0
End Select
End With
End If


ws_exit:
Application.EnableEvents = True
End Sub

Eh, you know how I said it all works fine.. well, I think I may have
been hallucinating...

I changed the code to evaluate not just M3 by using Case Is <= Date and
I put in the IfElse statements n now it's buggered...

Everything seems to be fine apart from the last part (date condition).
The code above is the one I posted earlier. Have i got the syntax
wrong? I have left out the elseIf's for now cause I know it worked
before I did that.

The new date condition code is:

If Not Intersect(Target, Me.Range("M3:M500")) Is Nothing Then
With Target
Select Case .Value
Case Is <= Date:
Cells(.row, 2).Resize(, 22).Interior.ColorIndex = 3
.Font.ColorIndex = 0
End Select
End With
End If

This turns the cell range interior red and the font black not white
then if you enter Y in K3:K500 it turns the font red?? N if no value is
in M3 after this then the whole thing stays red.

What's supposed to happen is... the record in that line is supposed to
be (1)font.colorindex = 3 and font.bold = true if there is a "Y" in K3.
If there is (2)CONDITION 1 in L3 then it should be interior.colorindex
= 15 and if (3)CONDITION 2 then interior.colorindex = 35. (4)If the
date in M3 passes today then it should be interior.colorindex = 3 and
font.colorindex = 0 and font.bold = true. When I had it wokring earlier
it even worked correctly when I took out values individually in each of
the cells to be evaluated and formatted according to what values were
left.

Lol. What I don't understand is I posted the code after I discovered it
worked cause I was so happy I'd managed it! N that doesn't work now
either! I supposed I must have done somthing to it just before I posted
it!

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