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

 

[Fluff]

How about

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

On Error GoTo EndMacro
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
      Ary(R, 1) = ""
      n = n + 1
   End If
Next R
End With
Rng.Value = Ary

EndMacro:

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

 

[sakrams]

.

 

[sakrams]

How about

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

On Error GoTo EndMacro
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
      Ary(R, 1) = ""
      n = n + 1
   End If
Next R
End With
Rng.Value = Ary

EndMacro:

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

Wow... This is amazingly fast. Thanks a million Fluff.

 

[Fluff]

You're welcome & thanks for the feedback.

 

[TedX]

Wow... This is amazingly fast. Thanks a million Fluff.

Hi Men, that's a really interesting piece of code, it is useful to me as I wish to delete duplicates on a daily basis and the way this works (so far with my testing) is that it deletes from the bottom up, which is exactly what I want. I was wondering if this script could actually delete the entire row, rather than just delete the contents of the selected column. The other thing which is a little weird, is as I do tests of different numbers of duplicates, and I get to the end MsgBox, it reports a funny number. I just ran it with one only duplicate which is got rid of and the message it showed was, "Duplicate Rows Deleted: 11351" That's no big deal because I just click Ok anyway, but curious as to why it's reporting such a large number.

 

[Fluff]

How about

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

On Error GoTo EndMacro
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
EndMacro:

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

I suspect you are getting odd numbers because the used range is probably larger than the actual data so it's deleting blank rows.

 

[TedX]

How about

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

On Error GoTo EndMacro
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
EndMacro:

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

I suspect you are getting odd numbers because the used range is probably larger than the actual data so it's deleting blank rows.

Thanks Fluff, that is the best name of all time I tried the script but it doesn't actually do anything, whereas the original does, I'm sure it's only the smallest thing

 

[Fluff]

What does the message box say?

 

[TedX]

What does the message box say?

It says, "Duplicate Rows Deleted: 300", which is the number of duplicates that should be deleted, but aren't. I start with 10,694, then get your message and still have 10,694. Nothing actually happens, except for the count being correct.