VBA - Delete Duplicate Rows - Except First and Last

[Smerdyakov007]

Hello guys,

I need your help in writing a macro code to create a time in/time out report. My requirement would be to delete the duplicate rows (based on the 'ID' column) except the first row, but the 'Time Out' column should be having the value of the last duplicate row.

Below is how the report would be looking firstly:

Date​	Time In​	Time Out​	ID​
01-07-2016​	13:30​	13:35​	1223​
01-07-2016​	14:30​	14:35​	1223​
01-07-2016​	15:30​	15:35​	1223​
01-07-2016​	16:30​	16:35​	1224​
01-07-2016​	17:30​	17:35​	1224​
01-07-2016​	18:30​	18:35​	1224​
01-07-2016​	19:30​	19:35​	1224​
01-07-2016​	20:30​	20:35​	1224​
01-07-2016​	21:30​	21:35​	1224​
01-07-2016​	22:30​	22:35​	1225​
01-07-2016​	23:30​	23:35​	1225​
01-07-2016​	00:30​	00:35​	1225​
01-07-2016​	01:30​	01:35​	1225​
01-07-2016​	02:30​	02:35​	1225​
01-07-2016​	03:30​	03:35​	1225​

The final output should be looking like below:

Date​	Time In​	Time Out​	ID​
01-07-2016​	13:30​	15:35​	1223​
01-07-2016​	16:30​	21:35​	1224​
01-07-2016​	22:30​	03:35​	1225​

Is this possible???

 

[mumps]

Try:

Sub DeleteDups()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, fVisRow As Long, lVisRow As Long, lRow As Long
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("D2:D" & lRow).Value
    With CreateObject("scripting.dictionary")
        For i = UBound(v) To LBound(v) Step -1
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Range("A1").AutoFilter 4, v(i, 1)
                If [subtotal(103,A:A)] - 1 > 1 Then
                    fVisRow = Rows("2:" & lRow).SpecialCells(xlCellTypeVisible).Row
                    lVisRow = Cells(Rows.Count, "A").End(xlUp).Row
                    Range("C" & fVisRow) = Range("C" & lVisRow)
                    Rows(fVisRow + 1 & ":" & lVisRow).Delete
                End If
            End If
        Next i
    End With
    Range("A1").AutoFilter
End Sub

 

[James006]

Hi,
You could use MINIFS for Time In and MAXIFS for Time out ...

 

[Smerdyakov007]

Try:

Sub DeleteDups()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, fVisRow As Long, lVisRow As Long, lRow As Long
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("D2:D" & lRow).Value
    With CreateObject("scripting.dictionary")
        For i = UBound(v) To LBound(v) Step -1
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Range("A1").AutoFilter 4, v(i, 1)
                If [subtotal(103,A:A)] - 1 > 1 Then
                    fVisRow = Rows("2:" & lRow).SpecialCells(xlCellTypeVisible).Row
                    lVisRow = Cells(Rows.Count, "A").End(xlUp).Row
                    Range("C" & fVisRow) = Range("C" & lVisRow)
                    Rows(fVisRow + 1 & ":" & lVisRow).Delete
                End If
            End If
        Next i
    End With
    Range("A1").AutoFilter
End Sub

Thank you so much. This worked

 

[mumps]

You are very welcome.

 

[sksanjeev786]

Hi,
You could use MINIFS for Time In and MAXIFS for Time out ...

Hi James could you please share the function for this

Regards
Sanjeev