Delete Duplicates based on Earliest or Latest Time

[jturner]

Hi,

Below is an example of an Excel sheet I'm working with:

Duplicates_Time.xls

Basically, I'm trying to delete the duplicate rows by matching ID, Date and Type. If ID, Date and Type are the same, then, I want to only keep the record with the earliest Time in case of Type = In and the latest Time in case of Type = Out.

So, for example, in the case of ID = 1, there are 3 records for In, I only want to keep the one where Time is: 8:01 as this is the earliest. The other 2 records should be deleted.

Similarly, in the case of ID 3, I want to keep the record where Time = 18:05 as this is the later time out of the 2.

Can this be achieved by Conditional Formatting or Macro or VBA?

Many thanks for your help in advance.

[Bob Phillips]

Sub DeleteData()
Const FORMULA_DELETE As String = _
    "=OR($D3=MIN(IF(($A$3:$A$<lastrow>=A3)*($E$3:$E$<lastrow>=""In""),$D$3:$D$<lastrow>))," & _
        "$D3=MAX(IF(($A$3:$A$<lastrow>=A3)*($E$3:$E$<lastrow>=""Out""),$D$3:$D$<lastrow>)))"
Dim rng As Range
Dim lastrow As Long
Dim i As Long


    With ActiveSheet
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Columns("I").Insert
        .Rows(1).Insert
        .Range("I1:I2").Value = Array("tmp", "TRUE")
        .Range("I3").FormulaArray = Replace(FORMULA_DELETE, "<lastrow>", lastrow + 1)
        .Range("I3").AutoFill .Range("I3").Resize(lastrow - 1)
        Set rng = .Range("I1").Resize(lastrow)
        rng.AutoFilter 1, "=FALSE"
        On Error Resume Next
        Set rng = rng.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rng Is Nothing Then
        
            rng.EntireRow.Delete
        End If
        .Columns("I").Delete
    End With
End Sub

[Azumi]

Maybe with formula could helps...

[Bob Phillips]

You can do it with a much simpler formula,

=MIN(IF(($A$2:$A$8=$B11)*($E$2:$E$8="In"),$D$2:$D$8))

and

=MAX(IF(($A$2:$A$8=$B11)*($E$2:$E$8="Out"),$D$2:$D$8))