code for last date on contact

Hi Burt,

I put them in AO since AK was occupied - just change the red code to put them wherever you want

Sub BurtLDOC(): Dim wr As Worksheet, wd As Worksheet
                Dim r As Long, CNo As Long, LD As Date
Set wr = Sheets("Reminders"): Set wd = Sheets("Data")
LD = #1/1/1900#
With CreateObject("Scripting.Dictionary")
For r = 2 To wr.Range("F" & Rows.count).End(xlUp).Row
        CNo = wr.Range("F" & r): .Item(CNo) = LD
Next r
For r = 2 To wd.Range("D" & Rows.count).End(xlUp).Row
If IsDate(wd.Range("G" & r)) Then
    CNo = wd.Range("D" & r): LD = wd.Range("G" & r)
If .Exists(CNo) Then
If LD > .Item(CNo) Then .Item(CNo) = LD
End If: End If: Next r
For r = 2 To wr.Range("F" & Rows.count).End(xlUp).Row
CNo = wr.Range("F" & r)
If Year(.Item(CNo)) <> 1900 Then
wr.Range("AO" & r) = .Item(CNo)
End If: Next r
End With
End Sub