Delete duplicate rows based on ID

jackjoush
NewLounger
Posts: 19
Joined: 25 Mar 2021, 21:33

Delete duplicate rows based on ID

Post by jackjoush »

Greetings,
I am hoping this is a relatively straightforward question, but this is still a little over my head.
I have written the code below to Delete duplicate rows based on ID in Column A

Code: Select all

Sub Delete_Shift()
Dim i As Long
Set MySheet = Sheets("Sheet1")
With MySheet
Last = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Application.ScreenUpdating = False
        For i = .Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
        If WorksheetFunction.CountIf(.Range("A2:A" & i), .Range("A" & i).Value) > 1 Then
            .Rows(i & ":" & i).Delete Shift:=xlUp
            End If
        Next i
Application.ScreenUpdating = True
End With
End Sub

The code is working when there is few lines. But it is taking too much time when there is more rows ( about 30000 rows )
How can update the code to run faster.
Please consider checking out my work. Thanks in advance for any assistance.!
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Delete duplicate rows based on ID

Post by HansV »

Try this. The code builds a range of rows to be deleted, then at the end, deletes them all in one go.
I explicitly declared all variables, corrected some mistakes and made the indentation consistent.

Code: Select all

Sub DeleteDuplicateRows()
    Dim MySheet As Worksheet
    Dim i As Long
    Dim Last As Long
    Dim rng As Range
    Application.ScreenUpdating = False
    Set MySheet = Sheets("Sheet1")
    With MySheet
        Last = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = Last To 2 Step -1
            If WorksheetFunction.CountIf(.Range("A2:A" & i), .Range("A" & i).Value) > 1 Then
                If rng Is Nothing Then
                    Set rng = .Range("A" & i)
                Else
                    Set rng = Union(.Range("A" & i), rng)
                End If
            End If
        Next i
    End With
    If Not rng Is Nothing Then
        rng.EntireRow.Delete
    End If
    Application.ScreenUpdating = True
End Sub
Best wishes,
Hans

jackjoush
NewLounger
Posts: 19
Joined: 25 Mar 2021, 21:33

Re: Delete duplicate rows based on ID

Post by jackjoush »

Thanks Hans for the improvements, I tested it on original data but it took more than 6 minutes.
Perhaps there is a better and faster way to achieve that?
Dear sir, can you please help me with this .. Thank you once again for the support and your patience.

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Delete duplicate rows based on ID

Post by HansV »

Use the built-in Remove Duplicates feature:

Code: Select all

Sub DeleteDuplicateRows()
    Application.ScreenUpdating = False
    Worksheets("Sheet1").UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
    Application.ScreenUpdating = True
End Sub
Best wishes,
Hans

jackjoush
NewLounger
Posts: 19
Joined: 25 Mar 2021, 21:33

Re: Delete duplicate rows based on ID

Post by jackjoush »

Thank you so much Hans , worked like a charm.