Bob,
Here is the initial script that searches the records:
Private Sub UpdateListsButton_Click()
' Updates all Lists
MsgBox "You are about to update records. This may take a few minutes.",
vbOKOnly, "Notice"
Application.ScreenUpdating = False
' Verifies correct status
Sheet7.Visible = xlSheetVisible
Sheet2.Visible = xlSheetVisible
Sheet1.Visible = xlSheetVisible
Sheet1.Activate
Udts = 0
Rcds = Application.CountA(ActiveSheet _
.Range("X:X"))
Ind = "N"
Sts = "EXPIRED"
Set f = Columns(24).Find(What:=Ind)
If f Is Nothing Then
MsgBox "No records were found that needed updating.", vbOKOnly, "Update
Complete"
Exit Sub
End If
f.Offset(0, 0).Activate
Set PetSur = ActiveCell.Offset(0, -20)
Set PetNam = ActiveCell.Offset(0, -19)
Set RspSur = ActiveCell.Offset(0, -16)
Set RspNam = ActiveCell.Offset(0, -15)
Set IssDat = ActiveCell.Offset(0, -14)
Set ExpDat = ActiveCell.Offset(0, -13)
FF = PetSur & PetNam & RspSur & RspNam & IssDat & ExpDat
If ActiveCell.Offset(0, -21).Value = Sts Then
ActiveCell.EntireRow.Copy
Sheet2.Activate
LastPlc = Application.CountA(ActiveSheet _
.Range("D
")) + 1 ' Finds last cell/row plus one
Cells(LastPlc, 1).PasteSpecial
Sheet7.Activate
LastPlc = Application.CountA(ActiveSheet _
.Range("A:A")) + 4 ' Finds last cell/row plus one
Cells(LastPlc, 1).Value = PetSur
Cells(LastPlc, 2).Value = PetNam
Cells(LastPlc, 3).Value = RspSur
Cells(LastPlc, 4).Value = RspNam
Cells(LastPlc, 5).Value = IssDat
Cells(LastPlc, 6).Value = ExpDat
Sheet1.Activate
Udts = Udts + 1
Rcds = Rcds - 1
End If
Set f = Columns(24).FindNext(After:=f)
f.Offset(0, 0).Activate
Do
Set PetSur = ActiveCell.Offset(0, -20)
Set PetNam = ActiveCell.Offset(0, -19)
Set RspSur = ActiveCell.Offset(0, -16)
Set RspNam = ActiveCell.Offset(0, -15)
Set IssDat = ActiveCell.Offset(0, -14)
Set ExpDat = ActiveCell.Offset(0, -13)
FND = PetSur & PetNam & RspSur & RspNam & IssDat & ExpDat
If FND = FF Then
Exit Do
End If
If ActiveCell.Offset(0, -21).Value = Sts Then
ActiveCell.EntireRow.Copy
Sheet2.Activate
LastPlc = Application.CountA(ActiveSheet _
.Range("D
")) + 1 ' Finds last cell/row plus one
Cells(LastPlc, 1).PasteSpecial
Sheet7.Activate
LastPlc = Application.CountA(ActiveSheet _
.Range("A:A")) + 4 ' Finds last cell/row plus one
Cells(LastPlc, 1).Value = PetSur
Cells(LastPlc, 2).Value = PetNam
Cells(LastPlc, 3).Value = RspSur
Cells(LastPlc, 4).Value = RspNam
Cells(LastPlc, 5).Value = IssDat
Cells(LastPlc, 6).Value = ExpDat
Udts = Udts + 1
Sheet1.Activate
End If
Set f = Columns(24).FindNext(After:=f)
f.Offset(0, 0).Activate
Loop
Rcds = Application.CountA(ActiveSheet _
.Range("X:X"))
Ind = "N"
Sts = "TERMINATED"
Set f = Columns(24).Find(What:=Ind)
f.Offset(0, 0).Activate
Set PetSur = ActiveCell.Offset(0, -20)
Set PetNam = ActiveCell.Offset(0, -19)
Set RspSur = ActiveCell.Offset(0, -16)
Set RspNam = ActiveCell.Offset(0, -15)
Set IssDat = ActiveCell.Offset(0, -14)
Set ExpDat = ActiveCell.Offset(0, -13)
FF = PetSur & PetNam & RspSur & RspNam & IssDat & ExpDat
If ActiveCell.Offset(0, -21).Value = Sts Then
ActiveCell.EntireRow.Copy
Sheet2.Activate
LastPlc = Application.CountA(ActiveSheet _
.Range("D
")) + 1 ' Finds last cell/row plus one
Cells(LastPlc, 1).PasteSpecial
Sheet7.Activate
LastPlc = Application.CountA(ActiveSheet _
.Range("A:A")) + 4 ' Finds last cell/row plus one
Cells(LastPlc, 1).Value = PetSur
Cells(LastPlc, 2).Value = PetNam
Cells(LastPlc, 3).Value = RspSur
Cells(LastPlc, 4).Value = RspNam
Cells(LastPlc, 5).Value = IssDat
Cells(LastPlc, 6).Value = ExpDat
Sheet1.Activate
Udts = Udts + 1
Rcds = Rcds - 1
End If
Set f = Columns(24).FindNext(After:=ActiveCell)
f.Offset(0, 0).Activate
Do
Set PetSur = ActiveCell.Offset(0, -20)
Set PetNam = ActiveCell.Offset(0, -19)
Set RspSur = ActiveCell.Offset(0, -16)
Set RspNam = ActiveCell.Offset(0, -15)
Set IssDat = ActiveCell.Offset(0, -14)
Set ExpDat = ActiveCell.Offset(0, -13)
FND = PetSur & PetNam & RspSur & RspNam & IssDat & ExpDat
If FND = FF Then
Exit Do
End If
If ActiveCell.Offset(0, -21).Value = Sts Then
ActiveCell.EntireRow.Copy
Sheet2.Activate
LastPlc = Application.CountA(ActiveSheet _
.Range("D
")) + 1 ' Finds last cell/row plus one
Cells(LastPlc, 1).PasteSpecial
Sheet7.Activate
LastPlc = Application.CountA(ActiveSheet _
.Range("A:A")) + 4 ' Finds last cell/row plus one
Cells(LastPlc, 1).Value = PetSur
Cells(LastPlc, 2).Value = PetNam
Cells(LastPlc, 3).Value = RspSur
Cells(LastPlc, 4).Value = RspNam
Cells(LastPlc, 5).Value = IssDat
Cells(LastPlc, 6).Value = ExpDat
Udts = Udts + 1
Sheet1.Activate
End If
Set f = Columns(24).FindNext(After:=f)
f.Offset(0, 0).Activate
Loop
If Udts = 0 Then
MsgBox "All records are up-to-date. No records needed updated.", _
vbOKOnly, "No updates needed"
Exit Sub
End If
lp = 0
If Udts >= 1 Then
Sheet7.Activate
ActiveSheet.PrintOut
Udts2 = Udts
Do Until Udts2 = 0
Udts2 = Udts - 1
lp = lp + 1
Cells(7, 1).Activate
ActiveCell.EntireRow.Delete
If lp = 1000 Then
Exit Do
End If
Loop
End If
Sheet7.Visible = xlSheetVeryHidden
Sheet2.Visible = xlSheetVeryHidden
Sheet1.Visible = xlSheetVeryHidden
Sheet4.Activate
Application.ScreenUpdating = True
MsgBox "All lists have been updated. " & Udts & " records have been
updated.", _
vbOKOnly, "Update Complete"
End Sub
This is the formula that returns the status of "VALID", "EXPIRED",
"TERMINATED", or "INVALID", which is the actual contents of the cells in
column "C":
=IF(D4="","INVALID",(IF(H4="","INVALID",(IF(M4="YES","TERMINATED",(IF(K4="INDEF","VALID",(IF(ISTEXT(K4),"INVALID",(IF(K4>=TODAY(),"VALID",(IF(K4="","INVALID","EXPIRED")))))))))))))
Cell references here are as follows:
D4 - 1st Person Last name
H4 - 2nd Person Last name
M4 - Yes/No field if it has been terminated
K4 - Expiration date
Thanks for your help.