Speeding the Remove Duplicate Formula

[sakrams]

Greeting Excel Gurus,

I have been using below macro to clear duplicates. The best part about his macro is that it clear the dupes but does not delete the rows or sorts the data (it only clear the duplicate values with no rearrangement of cells). However, when I run this formula on 200,000+ rows, excel freezes. I have left the computer for one full day to see if excel comes back but with no luck. Wondering if there is a way to speed this macro?

Public Sub ClearDuplicateRows()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteDuplicateRows
' This will delete duplicate records, based on the Active Column. That is,
' if the same value is found more than once in the Active Column, all but
' the first (lowest row number) will be deleted.
'
' To run the macro, select the entire column you wish to scan for
' duplicates, and run this procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim R As Long
Dim n As Long
Dim V As Variant
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
                    ActiveSheet.Columns(ActiveCell.Column))

Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")

n = 0
For R = Rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
    Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If

V = Rng.Cells(R, 1).Value
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Note that COUNTIF works oddly with a Variant that is equal to vbNullString.
' Rather than pass in the variant, you need to pass in vbNullString explicitly.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If V = vbNullString Then
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
        Rng.Rows(R).Clear
        n = n + 1
    End If
Else
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
        Rng.Rows(R).Clear
        n = n + 1
    End If
End If
Next R

EndMacro:

Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(n)

End Sub

 

[TedX]

No error messages, it appears to work perfectly, except it doesn't actually delete the rows. Under what conditions would Excel decide to disobey a direct order?

You are right about the number, I deleted every row that contained anything below the last data row and ran it again, it now stated it deleted 300 rows, which is the correct number, but of course, those rows are still there.

 

[Fluff]

Forgot there was an error handler in the OP's code try

Public Sub ClearDuplicateRows()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteDuplicateRows
' This will delete duplicate records, based on the Active Column. That is,
' if the same value is found more than once in the Active Column, all but
' the first (lowest row number) will be deleted.
'
' To run the macro, select the entire column you wish to scan for
' duplicates, and run this procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim R As Long
Dim n As Long
Dim Ary As Variant
Dim Rng As Range, DelRng As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
                    ActiveSheet.Columns(ActiveCell.Column))
Ary = Rng.Value

n = 0
With CreateObject("scripting.dictionary")
For R = 2 To UBound(Ary)
   If Not .Exists(Ary(R, 1)) Then
      .Add Ary(R, 1), Nothing
   Else
      If DelRng Is Nothing Then Set DelRng = Rng.Rows(R) Else Set DelRng = Union(DelRng, Rng.Rows(R))
      n = n + 1
   End If
Next R
End With
Rng.Value = Ary
If Not DelRng Is Nothing Then DelRng.EntireRow.Delete

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(n)
End Sub

 

[TedX]

Forgot there was an error handler in the OP's code try

Public Sub ClearDuplicateRows()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteDuplicateRows
' This will delete duplicate records, based on the Active Column. That is,
' if the same value is found more than once in the Active Column, all but
' the first (lowest row number) will be deleted.
'
' To run the macro, select the entire column you wish to scan for
' duplicates, and run this procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim R As Long
Dim n As Long
Dim Ary As Variant
Dim Rng As Range, DelRng As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
                    ActiveSheet.Columns(ActiveCell.Column))
Ary = Rng.Value

n = 0
With CreateObject("scripting.dictionary")
For R = 2 To UBound(Ary)
   If Not .Exists(Ary(R, 1)) Then
      .Add Ary(R, 1), Nothing
   Else
      If DelRng Is Nothing Then Set DelRng = Rng.Rows(R) Else Set DelRng = Union(DelRng, Rng.Rows(R))
      n = n + 1
   End If
Next R
End With
Rng.Value = Ary
If Not DelRng Is Nothing Then DelRng.EntireRow.Delete

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(n)
End Sub

Okay, got the new code and ran it, and got the following error.

Then when I hit the Debug button, I got this:

 

[Fluff]

Is the data in a proper Table, or just a range?

 

[TedX]

Is the data in a proper Table, or just a range?

Now that's interesting. The original data is in a table with the filters turned off. I copied and pasted the entire worksheet into a new worksheet and the data is still in a Table but the filters are switched on. So now I have just switched the filters off in the 2nd worksheet and run the script and got the exact same result as I showed you in the reply above. "Delete method of range class failed". I bet you the next thing you suggest will fix it

 

[Fluff]

Tables are a right pain (IMO) the cons far outweigh the pros.

 

[TedX]

Tables are a right pain (IMO) the cons far outweigh the pros.

LOL, you have given me an idea because I really wanted this to work for you. Talking about Tables got me thinking, why don't I just delete the duplicates manually, so I did and in an instant the 300 dupes were ancient history Now I know that's not a VBA fix and I can't use a macro, well I'll try and do a macro but it's unlikely it will record everything I do, actually, I'll try it and let you know. Here's an image with where I went to see the range of my table and spotted the Remove suplicates. I had previously tried that via the Data tab, but going in via the Table Design, just worked.

 

[Fluff]

Glad you sorted it & thanks for letting us know.

 

[TedX]

Glad you sorted it & thanks for letting us know.

Fluff old mate, you are a true legend. I swear I will pay it forward