hk129
07-23-2015, 07:32 AM
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!
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!