Worksheet event to change formatting when date expires.

D

DDawson

I have a macro to trigger conditional formatting events in my worksheet,
based on the cell text content in column D.

I also need an event that will update the formatting if the date in column G
is less than now, i.e. when it expires.

I have tried the following as conditional formatting, but I cannot copy the
formats down the columns, because I will lose all the existing formatting,
based on column D.

=AND($G23<NOW(),$D23="Statement") - Grey fill and light blue font colour
=AND($G23<NOW(),$D23<>"Closed") - Red font colour

My existing macro is as follows; but, I doubt a change event will work,
because I am not actually changing the contents of the cells containing the
dates. Is there a way to trigger a worksheet event to update the formatting
when the date in column G expires?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim WatchRange As Range
Dim CellVal As String
If Target.Cells.Count > 1 Then Exit Sub

Application.ScreenUpdating = False

'If Target = "" Then Exit Sub (See Case "")
CellVal = Target
Set WatchRange = Range("D1:D1000") 'change to suit

If Not Intersect(Target, WatchRange) Is Nothing Then
Select Case CellVal

Case "Pending"
'Target.Interior.ColorIndex = 5 (To Colour the single Cell)
' Target.EntireRow.Interior.ColorIndex = 36 (To Colour the entire row
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Interior.ColorIndex = 36
'(For columns A:G)
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Font.ColorIndex = 0

Case "Statement"
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Interior.ColorIndex = 34
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Font.ColorIndex = 0

Case "Closed"
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Interior.ColorIndex = 15
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Font.ColorIndex = 16

Case "Open"
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Interior.ColorIndex = 0
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Font.ColorIndex = 0

Case ""
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Interior.ColorIndex = 0
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Font.ColorIndex = 0

End Select
End If
Application.ScreenUpdating = True
End Sub
 
B

Bernie Deitrick

DD,

You can use the calculate event: see code below.

HTH,
Bernie
MS Excel MVP

Private Sub Worksheet_Calculate()

Dim WatchRange As Range
Dim myC As Range

Set WatchRange = Range("D1:D1000") 'change to suit

For Each myC In WatchRange

Select Case myC.Value
Case "Pending"
'Target.Interior.ColorIndex = 5 (To Colour the single Cell)
' Target.EntireRow.Interior.ColorIndex = 36 (To Colour the entire row
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Interior.ColorIndex = 36
'(For columns A:G)
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Font.ColorIndex = 0

Case "Statement"
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Interior.ColorIndex = 34
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Font.ColorIndex = 0

Case "Closed"
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Interior.ColorIndex = 15
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Font.ColorIndex = 16

Case "Open"
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Interior.ColorIndex = 0
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Font.ColorIndex = 0

Case ""
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Interior.ColorIndex = 0
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Font.ColorIndex = 0

End Select


' > =AND($G23<NOW(),$D23="Statement") - Grey fill and light blue font colour
If myC.Offset(0, 3).Value < Now And myC.Value = "Statement" Then
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Interior.ColorIndex = 15
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Font.ColorIndex = 34
End If

' > =AND($G23<NOW(),$D23<>"Closed") - Red font colour
' wasn't sure what background you wanted....
If myC.Offset(0, 3).Value < Now And myC.Value <> "Closed" Then
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Interior.ColorIndex = 15
Range(myC.Offset(0, -3), myC.Offset(0, 3)).Font.ColorIndex = 3
End If

Next myC
Application.ScreenUpdating = True
End Sub
 
D

DDawson

Thanks Bernie,

I tried the calculate method, but it doesn't apply until I save the
document. I wanted something that takes immediate effect.

However, I was able to cut and paste your additions into my code and replace
"myC" with "Target" to make the Change Event work.
=AND($G23<NOW(),$D23="Statement") - Grey fill and light blue font colour
Click to expand...
If Target.Offset(0, 3).Value < Now And Target.Value = "Statement" Then
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Interior.ColorIndex =
15
Range(Target.Offset(0, -3), Target.Offset(0, 3)).Font.ColorIndex = 34
End If

Kind Regards
Dylan
 
B

Bernie Deitrick

The calculate event will work when the sheet calculates - which is when the date values would
change. You need to have at least one volatile function on the worksheet to force the calculate -
putting =NOW() into a cell would make the event work.

HTH,
Bernie
MS Excel MVP
 
D

DDawson

Bernie,

I note your point about making the calculation happen, but I don't mind if
it updates on document open, close, or save. However, I probably will add the
=Now() function at a later date. However, I'm still having trouble getting
this to work.

I've kept my original worksheet change event to apply the formatting based
on status and I've added a worksheet calculate event to change it according
to date, as follows below.

The problem is when I calculate it the whole sheet turns yellow.

I have tested this by swapping the if statements around and have found out
that this is happening because the macro is applying all the if statements
i.e. the final statement makes the interior yellow.

Private Sub Worksheet_Calculate()
Dim myC As Range
Dim WatchRange1 As Range

Application.ScreenUpdating = False

Set WatchRange1 = Range("G2:G1000")

For Each myC In WatchRange1

If myC.Cells.Value < Now And myC.Offset(0, -3).Value = "Statement" Then
Range(myC, myC.Offset(0, -6)).Interior.ColorIndex = 15 'Grey
Range(myC, myC.Offset(0, -6)).Font.ColorIndex = 34 'light blue
Else
Range(myC, myC.Offset(0, -6)).Interior.ColorIndex = 34 'light blue
Range(myC, myC.Offset(0, -6)).Font.ColorIndex = 0 'black
End If

If myC.Value < Now And myC.Offset(0, -3).Value = "Closed" Then
Range(myC, myC.Offset(0, -6)).Interior.ColorIndex = 15 'light grey
Range(myC, myC.Offset(0, -6)).Font.ColorIndex = 16 'dark grey
End If

If myC.Value < Now And myC.Offset(0, -3).Value = "Open" Then
Range(myC, myC.Offset(0, -6)).Font.ColorIndex = 3 'red
Range(myC, myC.Offset(0, -6)).Interior.ColorIndex = 0 'clear
Else
Range(myC, myC.Offset(0, -6)).Font.ColorIndex = 0 'black
Range(myC, myC.Offset(0, -6)).Interior.ColorIndex = 0 'clear
End If

If myC.Value < Now And myC.Offset(0, -3).Value = "" Then
Range(myC, myC.Offset(0, -6)).Font.ColorIndex = 0 'clear
Range(myC, myC.Offset(0, -6)).Interior.ColorIndex = 0 'Black
Else
Range(myC, myC.Offset(0, -6)).Interior.ColorIndex = 0 'clear
Range(myC, myC.Offset(0, -6)).Font.ColorIndex = 0 'black
End If

If myC.Value < Now And myC.Offset(0, -3).Value = "Pending" Then
Range(myC, myC.Offset(0, -6)).Font.ColorIndex = 3 'red
Range(myC, myC.Offset(0, -6)).Interior.ColorIndex = 36 'yellow
Else
Range(myC, myC.Offset(0, -6)).Interior.ColorIndex = 36 'yellow
Range(myC, myC.Offset(0, -6)).Font.ColorIndex = 0 'black
End If

Next myC

Application.ScreenUpdating = True
End Sub

'--
Kind regards
Dylan
 
D

DDawson

I think i've fixed it using ElseIF statements, instead of individual If -
EndIfs.
Also I've added an =Now() function and it works great.

I'm now going to try removing the conditional formatting Change Event.

Regards Dylan
 

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

Similar Threads

Deleting specific information 1
input info when pasted in cells 5
Why are the two codes below not getting the right formula for myworksheet event change formula? 2
BeforeDoubleClick Event not working 2
How to create a shared procedure 3
Worksheet change code to colour in rows in a database 7
help with my code 4
a little tweaking might work? 6

Top