Sub Expired()
On Error Resume Next
Dim d As DAO.Database
Dim r As Recordset
Dim Status As Field, CalibrationDueDate As Field
Set d = CurrentDb()
Set r = CurrentDb.OpenRecordset("CalibrationDataBase")
Set Status = r.Fields("Status")
Set CalibrationDueDate = r.Fields("CalibrationDueDate")
Do Until r.EOF
If r!Status = "In Use" Or "Comes To End" Then
If DateDiff("d", Date, CalibrationDueDate) < 0 Then
r.Edit
r!Status = "Expired"
r.Update
End If
End If
r.MoveNext
Loop
r.Close
End Sub