Quicker Dupe Deleter VBA Help

[Snaps]

I'm currently using the following code to delete out any records that duplicate themselves in the A Column. I have lists that are thousands of rows long and when it runs it takes much longer than I would like. Was hoping there was a solution out there that was more efficient.

Using Excel 2003

** Sometimes I use multiple pieces of criteria (various columns) to delete dupes. This code is based solely on the A Coulmn.

Thanks again

Sub DupeDeleter()
x = ActiveCell.Row
y = x + 1
Do While Cells(x, 1).Value <> ""
Do While Cells(y, 1).Value <> ""
If (Cells(x, 1).Value = Cells(y, 1).Value) Then
Cells(y, 1).EntireRow.Delete
Else
y = y + 1
End If
Loop
x = x + 1
y = x + 1
Loop
End Sub

 

[VoG]

Try

Sub DupeDeleter()
Dim LR As Long, i As Long
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
    With Range("A" & i)
        If WorksheetFunction.CountIf(Columns("A"), .Value) > 1 Then .EntireRow.Delete
    End With
Next i
Application.ScreenUpdating = True
End Sub

 

[Snaps]

You are my hero

Thank you very much for that.

I'm a VBA novice so if I wanted to remove dupes based on Coulmns A & C how would the code change?

I believe if I had that knowledge I could edit it for any dupe application.

 

[VoG]

Try this with a copy of your sheet

Sub DupeDeleter()
Dim LR As Long, i As Long
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
Columns("A").Insert
Range("A1:A" & LR).Formula = "=B1&""_""&D1"
For i = LR To 2 Step -1
    With Range("A" & i)
        If WorksheetFunction.CountIf(Columns("A"), .Value) > 1 Then .EntireRow.Delete
    End With
Next i
Columns("A").Delete
Application.ScreenUpdating = True
End Sub