VBA to find the latest entry for each employee number

[Damo10]

Hi,

I am trying to write some code that will go through all the data in sheet2 starting on row 5 which looks at all the employee numbers and then finds only the latest entry for each employee and then copies the date for that employee (columns B:J) to the next blank row on sheet5 starting in cell B5. The employee numbers are in column D and the dates are in column B

There may be several entries for each employee but I only want to get the data for the most recent entry which can be found from the date in column B

Any help would be great as I am stuck

Regards,

 

[Fluff]

How about

Sub FindEachLatest()
   Dim Rng As Range
   Dim Cl As Range
   Dim Itm As Variant
   
   With Sheets("Sheet2")
      Set Rng = .Range("D5", .Range("D" & Rows.Count).End(xlUp))
   End With
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Rng
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Array(Cl.Offset(, -2).Value, Cl.Offset(, -2))
         ElseIf .Item(Cl.Value)(0) < Cl.Offset(, -2).Value Then
            .Item(Cl.Value) = Array(Cl.Offset(, -2).Value, Cl.Offset(, -2))
         End If
      Next Cl
      
      For Each Itm In .items
         Itm(1).Resize(, 9).Copy Sheets("Sheet5").Range("B" & Rows.Count).End(xlUp).Offset(1)
      Next Itm
   End With
   
End Sub

 

[Damo10]

Hi,

Many thanks for that, it appears to be working exactly as required.

Regards,

 

[Fluff]

Glad to help & thanks for the feedback