VBA to work out if a date is overdue

[ryandonovan22]

Hello,

I need a Macro to work out if a range of dates are overdue based on comparing expected delivery date against todays date

There could be any number of rows each week so it will have to perform the calculation over an undetermined range.

If I was to produce an if statement within the cell this is what I would use =if(G2<TODAY(),"Overdue",OK") and drag the formula down
<today(),"overdue","ok") range.

for the purpose of the VBA formula, this data will need to be placed into column N

Thanks,
Ryan.</today(),"overdue","ok")>

 

[Scott T]

Looks like your formula got cut off. Try putting spaces around any < . The forum will sometime think you are using HTML and drop what is after the < .

 

[ryandonovan22]

Formula is supposed to be =if(G2< TODAY(),"Overdue","OK") which would then be dragged down

 

[alansidman]

Try this:

Option Explicit


Sub Overdue()
    Dim i As Long, lr As Long
    lr = Range("G" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 2 To lr
        If Range("G" & i) < Date Then
            Range("N" & i) = "Overdue"
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[Scott T]

Try this.

Sub isoverdue()
Dim lr As Long
lr = Cells(Rows.Count, "G").End(xlUp).Row
For x = 2 To lr
    If Cells(x, "G") < Date Then
        Cells(x, "N") = "Overdue"
    Else
        Cells(x, "N") = "OK"
    End If
Next x
End Sub

 

[ryandonovan22]

Try this:

Option Explicit


Sub Overdue()
    Dim i As Long, lr As Long
    lr = Range("G" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 2 To lr
        If Range("G" & i) < Date Then
            Range("N" & i) = "Overdue"
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

I already have an entire sub completing all of the below.

How do I add this macro in without getting error (which I am currently getting)

Sub TidyAll()
'Delete columns
Columns(5).EntireColumn.Delete
Columns(5).EntireColumn.Delete
Columns(6).EntireColumn.Delete
Columns(6).EntireColumn.Delete
Columns(6).EntireColumn.Delete

' remove the leading zeros on part numbers
Dim myCell As Range
Dim myRng As Range
Dim iCtr As Long
With Worksheets("Raw Data")
Set myRng = .Range("C1", .Cells(.Rows.Count, "C").End(xlUp))
For Each myCell In myRng.Cells
For iCtr = 1 To Len(myCell.Value)
If Mid(myCell.Value, iCtr, 1) <> "0" Then
Exit For
End If
Next iCtr
myCell.Value = Mid(myCell.Value, iCtr)
Next myCell
End With

'Insert columns
Range("A1").EntireColumn.Insert
Range("A1").Select
ActiveCell.FormulaR1C1 = "Owner"
Range("N1").Select
ActiveCell.FormulaR1C1 = "Status"
Range("O1").Select
ActiveCell.FormulaR1C1 = "Confirmed Delivery Date"
Range("P1").Select
ActiveCell.FormulaR1C1 = "Outstanding Actions?"
Range("Q1").Select
ActiveCell.FormulaR1C1 = "Comments"
Range("R1").Select
ActiveCell.FormulaR1C1 = ""
Range("S1").Select
ActiveCell.FormulaR1C1 = ""

'Change cell color
Range("A1").Interior.ColorIndex = 6
Range("N1:S1").Interior.ColorIndex = 43

'Auto Filter sheet
Range("A1:S1").AutoFilter

'Center text
With Sheets("Raw Data")
.Range("A:S").HorizontalAlignment = xlCenter
End With
'Add boarders around cells
 With ActiveSheet.UsedRange.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
'Sort in ascending order
Range("A:S").Sort _
Key1:=Range("F1"), Header:=xlYes

'Looks up buyer linked to particular supplier.
With Sheets("Raw Data")
    With .Range("A2:A" & .Range("F" & .Rows.Count).End(xlUp).Row)
        .Formula = "=VLOOKUP(F2,'" & Sheets("Suppliers & Owners").Name & "'!$A$2:$B$51,2,0)"
        .Value = .Value
        .Replace "0", "Unallocated", LookAt:=xlWhole
    End With
End With

' Provides Overdue or OK status
 

' Set columns to auto fit
Worksheets("Raw Data").Range("A:S").Columns.AutoFit

MsgBox "Open Order Book Formatting Complete!"
End Sub

 

[alansidman]

What does your new code look like. Where did you insert the code provided. What is the error message you are receiving. When you get the error message, click on Debug and then tell us which line of code is highlighted. We really need to see what you see in order to analyze and help. Mind reading is not a specialty that we employ here.

 

[ryandonovan22]

What does your new code look like. Where did you insert the code provided. What is the error message you are receiving. When you get the error message, click on Debug and then tell us which line of code is highlighted. We really need to see what you see in order to analyze and help. Mind reading is not a specialty that we employ here.

I managed to get both Macros to function, although one was more successful than the other but neither worked 100%

I removed the Sub and End sub and inserted it into my existing sub.

This macro worked, but only displayed "OK" even when there should have been "Overdue" appearing

Dim lr As Long
lr = Cells(Rows.Count, "G").End(xlUp).Row
For x = 2 To lr
    If Cells(x, "G") < Date Then
        Cells(x, "N") = "Overdue"
    Else
        Cells(x, "N") = "OK"
    End If
Next x

 

[alansidman]

You need to tell us what is not working. Telling us it doesn't work is no help. What is missing?

 

[ryandonovan22]

Alan - your macro didn’t work. It ran fine but put no results in column N

Scott’s macro worked, but not properly. Instead of putting “overdue” where the date in Column G was <. Today’s date, it just put “OK” in all of the cells in column N