I have two functions that operate 'live' on a worksheet:
1, Fill cell ("A",i) with a pre- determined colour based on the number keyed in at that location.
2. For a date that is keyed in at ("L",x), do one of three things:
If the date is less than two years from todays date, colour the cell next to it green and insert text "OK"
If the date is more than two years from todays date, colour the cell next to red and insert text "Overdue"
The idea is that as dates are added to rows in column L, it is compared to today's date and as the date approaches a two year anniversary, it will flag up as yellow and being due, after that, if the date isn't updated, and goes over a two year point then will flag up as red and being overdue.
This seems to work fine sometimes but as I insert dates further down the rows, the blue spinning circle starts to appear and takes longer and longer to think about updating.
Clearing a cell doesn't always seem to clear the cell next to it either.
Could someone take a look at my code and offer words of wisdom to optimise it?
Additionally I've been trying to add an extra condition to function 2 that does this:
2. If the date in ("L",x) is within two months of its two year anniversary and becoming overdue, colour the cell next to it yellow and insert text "Due"
I can't seem to get to grips with the logic
Many thanks
Smudge
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
For i = 1 To 1000 '1000 being the number of rows to run on
If Cells(i, 1).Value = "1" Then
Cells(i, 1).Interior.Color = RGB(27, 252, 94)
ElseIf Cells(i, 1).Value = "2" Then
Cells(i, 1).Interior.Color = RGB(241, 51, 3)
ElseIf Cells(i, 1).Value = "3" Then
Cells(i, 1).Interior.Color = RGB(40, 208, 36)
ElseIf Cells(i, 1).Value = "4" Then
Cells(i, 1).Interior.Color = RGB(96, 142, 219)
ElseIf Cells(i, 1).Value = "5" Then
Cells(i, 1).Interior.Color = RGB(245, 254, 73)
ElseIf Cells(i, 1).Value = "6" Then
Cells(i, 1).Interior.Color = RGB(134, 193, 192)
ElseIf Cells(i, 1).Value = "7" Then
Cells(i, 1).Interior.Color = RGB(103, 224, 206)
ElseIf Cells(i, 1).Value = "8" Then
Cells(i, 1).Interior.Color = RGB(242, 168, 85)
ElseIf Cells(i, 1).Value = "9" Then
Cells(i, 1).Interior.Color = RGB(196, 254, 73)
ElseIf Cells(i, 1).Value = "10" Then
Cells(i, 1).Interior.Color = RGB(198, 118, 209)
ElseIf Cells(i, 1).Value = "11" Then
Cells(i, 1).Interior.Color = RGB(115, 75, 252)
ElseIf Cells(i, 1).Value = "12" Then
Cells(i, 1).Interior.Color = RGB(73, 254, 132)
ElseIf Cells(i, 1).Value = "Tru" Then
Cells(i, 1).Interior.Color = RGB(121, 208, 237)
Cells(i, 2).Interior.Color = RGB(121, 208, 237)
End If
Next i
If Not Intersect(Target, Range("L2:L1000")) Is Nothing Then
Call Review_Status
End If
End Sub
Sub Review_Status()
Dim x As Long, lr As Long
lr = Range("L" & Rows.Count).End(xlUp).Row ' Find the last populated row in column L and count up
Application.ScreenUpdating = False
For x = 2 To lr 'Set the increment for colum L to determine cell in row
If Range("L" & x).Value = "" Then 'If cell in range is blank, clear cell to the right of it
Range("M" & x).Value = ""
Cells(x, 13).Interior.Pattern = xlNone
ElseIf Range("L" & x).Value < (Date - 730) Or Range("L" & x).Value = "No data file" Then 'If date in cell is greater than two years from todays date or has no data file, colour cell to right as red and insert text "Overdue"
Range("M" & x).Value = "Overdue"
Cells(x, 13).Interior.Color = RGB(255, 0, 0)
ElseIf Range("L" & x).Value < (Date - 60) Then 'If date in cell is less than two years from todays date, colour cell to right as yellow and insert text "Due"
Range("M" & x).Value = "Due"
Cells(x, 13).Interior.Color = RGB(255, 255, 0)
Else: Range("M" & x) = "OK" 'If date in cell is less than two years from todays date, colour cell to right as green and insert text "Due"
Cells(x, 13).Interior.Color = RGB(0, 255, 0)
End If
Next x
Application.ScreenUpdating = True
End Sub