VBA - Delete Duplicate Rows Keep Last Entry

[soulman247]

After a frustrating morning trying varying methods, I can't seem to find one that does the job as required.

Here's the scenario:

We have a data set from a ticket management system that is updated at month end with each record having a unique ID in any data set. The latest data set is appended to the exisiting data. Duplicates are created when a record is open when a snapshot is taken (at one month end) and will then appear again in the next months snapshot when it may have be resolved and closed. Although other fields may change across the columns, column A will always have the unique identifier regardless.

I'm pretty sure the Advanced Filter can achieve this but I'd like it as a one button macro click as the intended users are, lets say, excel challenged

I would like a macro that looks in column A for duplicate values and deletes the entire row of any subsequent duplicates BUT retains the last entry (leaving one unique record) as it sits in row order.

For example, rows 10 and 20 may have an identical cells across all columns but I need row 10 to be deleted and row 20 to be left behind.

Hope this makes sense, any help greatly appreciated.

 

[BiocideJ]

This should do what you are looking for.
I tested this and it appears to be working, however, I would strongly recommend testing this on a copy since if something doesn't go as expected there is no way to undo a macro that deletes rows.

Sub Delete_Dups_Keep_Last()
Dim i As Long
Dim j As Long
Dim ROW_DELETED As Boolean
i = 1   'start on first row
Do While i <= ActiveSheet.UsedRange.Rows.Count
    ROW_DELETED = False
    For j = i + 1 To ActiveSheet.UsedRange.Rows.Count
        If Cells(i, 1) = Cells(j, 1) Then
            Rows(i).Delete
            ROW_DELETED = True
            Exit For
        End If
    Next j
    If Not ROW_DELETED Then i = i + 1
Loop
End Sub

 

[BiocideJ]

Additionally, if you are running this on a larger list of rows you should probably turn screen updating off.

Sub Delete_Dups_Keep_Last()
Dim i As Long
Dim j As Long
Dim ROW_DELETED As Boolean
i = 1   'start on first row
Application.ScreenUpdating = False
Do While i <= ActiveSheet.UsedRange.Rows.Count
    ROW_DELETED = False
    For j = i + 1 To ActiveSheet.UsedRange.Rows.Count
        If Cells(i, 1) = Cells(j, 1) Then
            Rows(i).Delete
            ROW_DELETED = True
            Exit For
        End If
    Next j
    If Not ROW_DELETED Then i = i + 1
Loop
Application.ScreenUpdating = True
End Sub

 

[soulman247]

Thank you so much BiocideJ - first code was a little slow but version is perfect for the expanding data.

Thank you

 

[excelfirst]

Hello @BiocideJ, your code works very well for the whole range of cells. I tried to only apply it to a selected range of cells but it errors out. Any suggestions? Thank you!!

Code:
Sub test4()
Dim i As Long
Dim j As Long
Dim ROW_DELETED As Boolean
Dim SelRng As Range


Application.DisplayAlerts = False
Set SelRng = Application.InputBox("Select cells", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True


Application.screenupdating = false
i = SelRng.Rows.Count
Set ws1 = Sheets("Sheet1")
Do While i <= Worksheets("Sheet1").UsedRange.Rows.Count
ROW_DELETED = False
For j = i + 1 To Worksheets("sheet1").UsedRange.Rows.Count
If Cells(i, 1) = Cells(j, 1) Then
Rows(i).Delete
ROW_DELETED = True
Exit For
End If
Next j
If Not ROW_DELETED Then i = i + 1
Loop
Application.ScreenUpdating = True


End Sub

 

[BiocideJ]

Well, this is an old post.
Interesting to see how much my coding has evolved since then.

Anyway, I have this amended (better) code that doesn't require turning screen-updating off as it has only a single DELETE call.
I also updated it to allow for your specific range selection criteria.

Sub Delete_Dups_Keep_Last_v2()
 Dim SelRng As Range
 Dim Cell_in_Rng As Range
 Dim RngToDelete As Range
 Dim SelLastRow As Long
 
    Application.DisplayAlerts = False
    Set SelRng = Application.InputBox("Select cells", Type:=8)
    On Error GoTo 0
    Application.DisplayAlerts = True
 
    SelLastRow = SelRng.Rows.Count + SelRng.Row - 1
    For Each Cell_in_Rng In SelRng
        
        If Cell_in_Rng.Row < SelLastRow Then
            If Not Cell_in_Rng.Offset(1, 0).Resize(SelLastRow - Cell_in_Rng.Row).Find(What:=Cell_in_Rng.Value, Lookat:=xlWhole) Is Nothing Then
                'this value exists again in the range
                If RngToDelete Is Nothing Then
                    Set RngToDelete = Cell_in_Rng
                Else
                    Set RngToDelete = Application.Union(RngToDelete, Cell_in_Rng)
                End If
            End If
        End If
        
    Next Cell_in_Rng
 
    If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete

End Sub

Also, +1 for the InputBox(, Type:=8) code, I had never seen that before and it seems very useful.

 

[excelfirst]

Thank you @BiocideJ. The new code works beautifully. Thank you very much

 

[davespen1973]

Hi, This is exactly what I was looking for, so thank you.

What is you want to keep any records that are not duplicates? I am running into the situation where is deletes non duplicate records.

Any help would be great!

Dave

Additionally, if you are running this on a larger list of rows you should probably turn screen updating off.

Sub Delete_Dups_Keep_Last()
Dim i As Long
Dim j As Long
Dim ROW_DELETED As Boolean
i = 1   'start on first row
Application.ScreenUpdating = False
Do While i <= ActiveSheet.UsedRange.Rows.Count
    ROW_DELETED = False
    For j = i + 1 To ActiveSheet.UsedRange.Rows.Count
        If Cells(i, 1) = Cells(j, 1) Then
            Rows(i).Delete
            ROW_DELETED = True
            Exit For
        End If
    Next j
    If Not ROW_DELETED Then i = i + 1
Loop
Application.ScreenUpdating = True
End Sub

 

[Shepard]

Hello,

Is there a way to implement the script for the column 1 of the given code?

Sub Process_Data2()

' Process_Data2 Macro

Range("A1:P2860").Select
Range("E1986").Activate
ActiveSheet.Range("$A$1:$P$1048576").RemoveDuplicates Columns:=Array(1, 2), _
Header:=xlYes
End Sub

Regards, Shepard