Macro to Move Data and Delete Extra Rows

[FrenchCelt]

Hello,

I have an Excel-based report that lists several people with a series of events listed in chronological order. I only need the start time of the first event and the end time of the final event for each individual. I do this manually by cutting that end time at the bottom of each series for each person and pasting it in the cell with the end time of the first event. The rest of the rows for each person are then deleted. I would like to code a macro that automates this process. Can anyone help?

This is basically what the report looks like initially:

Employee ID	Last Name	First Name	Begin Time	End Time	Supervisor
user1	Smith	John	5/28/2019 23:20	5/28/2019 23:21	sup_1
user1	Smith	John	5/28/2019 23:21	5/28/2019 23:25	sup_1
user2	Doe	Jane	5/29/2019 0:20	5/29/2019 0:42	sup_2
user2	Doe	Jane	5/29/2019 0:42	5/29/2019 1:26	sup_2

<tbody>
</tbody>

Here is what it should end up looking like:

Employee ID	Last Name	First Name	Begin Time	End Time	Supervisor
user1	Smith	John	5/28/2019 23:20	5/28/2019 23:25	sup_1
user2	Doe	Jane	5/28/2019 0:20	5/28/2019 1:26	sup_2

<tbody>
</tbody>

 

[Joe4]

Will the data always be sorted like this, so all the records for a particular user a group together in chronological order?
For a particular user, is it safe to assumes that the First Name, Last Name, and Supervisor fields will always be the same for all of the records for that user?

 

[FrenchCelt]

Yes, the data will always be sorted chronologically per user, and for each user, First Name, Last Name, and Supervisor fields will be the same.

 

[Joe4]

If the data is in columns A-F, with header on row 1 and data starting on row 2, this should work:

Sub CombineRecords()

    Dim r As Long

    Application.ScreenUpdating = False
    
'   Loop through all rows, starting on row 2
    r = 2
    Do Until Cells(r, "A") = ""
'       If value is same as above, update end date and delete record
        If Cells(r, "A") = Cells(r - 1, "A") Then
            Cells(r - 1, "E") = Cells(r, "E")
            Rows(r).Delete
'       Otherwise move to next row
        Else
            r = r + 1
        End If
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

 

[FrenchCelt]

Yes, that worked beautifully. Thank you so much!

 

[Joe4]

You are welcome.
Glad I was able to help!