Option Explicit
Sub MaxInDate()
Dim lRow As Long, Ww As Long
Dim Rng As Range, FindRng As Range
Dim GPE_Address As String
Sheet1.Select: lRow = [A65432].End(xlUp).Row
[e1] = "MaxDate": Application.ScreenUpdating = False
Range("A1:A" & lRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("D1"), Unique:=True
With Sheet1.Range("A1:A" & lRow)
For Ww = 2 To [d65432].End(xlUp).Row
Set Rng = .Find(What:=Cells(Ww, "D"), LookIn:=xlValues)
If Not Rng Is Nothing Then
Set FindRng = Rng.Offset(, 1)
GPE_Address = Rng.Address
Do
Set FindRng = Union(FindRng, Rng.Offset(, 1))
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> GPE_Address
End If
Cells(Ww, "E") = Application.WorksheetFunction.Max(FindRng)
Cells(Ww, "E").NumberFormat = "m/d/yyyy"
Next Ww
End With
End Sub