Enabling Macro to Active When Multiple Cells In Column Change

[hk129]

Hi guy,

I am writing a program to highlight when due dates (in column D) are overdue. The cell will turn red if it is overdue and will turn yellow if the date is within the next week. It is working right now but when I try to edit multiple cells (delete/ copy paste) in the column, I run into an error.

Here is the code I'm using right now:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range

Set KeyCells = Range("D1: D1048575")

If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then


'Code executes when column D has been changed
'Checks if the cell (in column D) has been modified
If Not Trim(Target.Value & vbNullString) = vbNullString Then
'Check if the date entered is valid
If IsDate(Target.Value) Then
'if the date is overdue or upcoming this week
If (DateDiff("d", Target.Value, Date) >= 0) Then
'highlights/unhighlights depending on whether or not we have a project number
If (Trim(Target.Offset(0, 1) & vbNullString) = vbNullString) Then
Target.Interior.ColorIndex = 3
Else
Target.Interior.ColorIndex = xlNone
End If
'if the due date is after a week but before two weeks
ElseIf ((DateDiff("d", Target.Value, Date) >= -7) And (DateDiff("d", Target.Value, Date) < 0)) Then
'highlights/unhighlights depending on whether or not we have a project number
If (Trim(Target.Offset(0, 1) & vbNullString) = vbNullString) Then
Target.Interior.ColorIndex = 6
Else
Target.Interior.ColorIndex = xlNone
End If

End If
Else
MsgBox "Invalid RFQ Due Date for quote " & Target.Offset(0, -3).Value & ". If due date is not know, please leave blank"
End If 'else
Else
Target.Interior.ColorIndex = xlNone 'if user had a date which was overdue (and highlighted red) but then removes that date from cell
End If 'if empty


End If
End Sub




I'm not sure if it's possible to do this. Would a function work for me? Thanks in advance for any help!

[Paul_Hossler]

Not tested, but I think you'll need to loop through all cells in the intersection (red)

I made a few other changes as I was tracing through, but I prefer to test for empty cells a little differently




Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range, rCell As Range
Set KeyCells = Range("D1: D1048575")
If Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then Exit Sub

For Each rCell In Application.Intersect(KeyCells, Range(Target.Address)).Cells
With rCell

If Len(Trim(.Value)) > 0 Then

'Check if the date entered is valid
If IsDate(.Value) Then

'if the date is overdue or upcoming this week
If (DateDiff("d", .Value, Date) >= 0) Then

'highlights/unhighlights depending on whether or not we have a project number
If Len(Trim(.Offset(0, 1).Value)) > 0 Then
.Interior.ColorIndex = 3
Else
.Interior.ColorIndex = xlNone
End If

'if the due date is after a week but before two weeks
ElseIf ((DateDiff("d", .Value, Date) >= -7) And (DateDiff("d", .Value, Date) < 0)) Then

'highlights/unhighlights depending on whether or not we have a project number
If Len(Trim(.Offset(0, 1).Value)) > 0 Then
.Interior.ColorIndex = 6
Else
.Interior.ColorIndex = xlNone
End If

End If
Else
MsgBox "Invalid RFQ Due Date for quote " & .Offset(0, -3).Value & ". If due date is not know, please leave blank"
End If 'else
Else
.Interior.ColorIndex = xlNone 'if user had a date which was overdue (and highlighted red) but then removes that date from cell
End If

End With
Next



End Sub

[hk129]

Thank you Paul Hossler!

I had to modify a few things but it worked great!