Sub MakeTheList()
    
    ' uses late binding
    
    Dim Contents As Variant
    Dim r As Long
    Dim dic As Object
    Dim TestEmp As String
    Dim TestDate As Date
    Dim Keys As Variant
    Dim EmpColl As Collection
    Dim DateColl As Collection
    
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    With ThisWorkbook.Worksheets("Data")
        
        ' Dump raw data into an array
        
        .Range("c1").Resize(1, .Columns.Count - 2).EntireColumn.Delete
        Contents = .Range("a2", .Cells(.Rows.Count, "B").End(xlUp)).Value
        
        ' Set up Collections.  Because we need to track two data elements (employee name and date),
        ' and because we cannot retrieve the keys from a Collection, we must set up two Collections:
        ' one to track employee names and one to track dates (both using employee name as the key)
        
        Set EmpColl = New Collection
        Set DateColl = New Collection
        
        ' Turn on error handling.  Collections have no explicit existence test, so the only way to
        ' know if an item exists is to try to add it or retrieve it, and then trap the error if it
        ' does not exist
        
        On Error Resume Next
        
        ' Loop through the array
        
        For r = 1 To UBound(Contents, 1)
            TestEmp = Contents(r, 1)
            TestDate = Contents(r, 2)
            
            ' Attempt to add the employee.  If employee already exists in Collection, this will
            ' throw a handled error
            
            EmpColl.Add TestEmp, TestEmp
            If Err = 0 Then
                
                ' No error = new employee; add the test date also
                
                DateColl.Add TestDate, TestEmp
            Else
                
                ' Error = existing employee.  Check the TestDate and see if it is earlier than the
                ' date we already have for the employee.  If TestDate is earlier, remove the current
                ' date from the Collection and add the newer, earlier date (items within a Collection
                ' cannot be reassigned)
                
                Err.Clear
                If TestDate < DateColl(TestEmp) Then
                    DateColl.Remove TestEmp
                    DateColl.Add TestDate, TestEmp
                End If
            End If
        Next
        On Error GoTo 0
        
        ' Write the results to the worksheet
        
        .Range("d1:e1").Value = Array("Collection" & Chr(10) & "Employee", "Date")
        For r = 1 To EmpColl.Count
            .Cells(r + 1, "d") = EmpColl(r)
            .Cells(r + 1, "e") = DateColl(EmpColl(r))
        Next
        
        ' Create Dictionary and loop through array
        
        Set dic = CreateObject("Scripting.Dictionary")
        For r = 1 To UBound(Contents, 1)
            TestEmp = Contents(r, 1)
            TestDate = Contents(r, 2)
            
            ' Test to see if current employee already exists
            
            If dic.Exists(TestEmp) Then
                
                ' Employee exists; update date if applicable
                
                If TestDate < dic.Item(TestEmp) Then dic.Item(TestEmp) = TestDate
            Else
                
                ' Employee does not exist, so add employee and date
                
                dic.Add TestEmp, TestDate
            End If
        Next
        
        ' Write results to worksheet
        
        Keys = dic.Keys
        .Range("g1:h1").Value = Array("Dictionary" & Chr(10) & "Employee", "Date")
        .Range("g2").Resize(dic.Count, 1).Value = Application.Transpose(Keys)
        For r = 0 To UBound(Keys)
            .Cells(r + 2, "h") = dic.Item(Keys(r))
        Next
        
        ' Format worksheet
        
        .Range("d:d").WrapText = True
        .Range("g:g").WrapText = True
        .Range("e:e").NumberFormat = "yyyy-mm-dd"
        .Range("h:h").NumberFormat = "yyyy-mm-dd"
        .Range("d:d").EntireColumn.ColumnWidth = 20
        .Range("g:g").EntireColumn.ColumnWidth = 20
        .Rows.AutoFit
        .Columns.AutoFit
        .Range("d1").Sort Key1:=.Range("d1"), Order1:=xlAscending, Header:=xlYes
        .Range("g1").Sort Key1:=.Range("g1"), Order1:=xlAscending, Header:=xlYes
    End With
    
    ' Destroy objects
    
    Set EmpColl = Nothing
    Set DateColl = Nothing
    Set dic = Nothing
    
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    
    MsgBox "Done"
    
End Sub

Select all