Speeding the Remove Duplicate Formula

sakrams

Board Regular
Joined
Sep 28, 2009
Messages
54
Office Version
  1. 2016
Platform
  1. Windows
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?




VBA Code:
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
 

Some videos you may like

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,412
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
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
 
Solution

sakrams

Board Regular
Joined
Sep 28, 2009
Messages
54
Office Version
  1. 2016
Platform
  1. Windows
How about
VBA Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,412
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,328
Messages
5,624,034
Members
416,007
Latest member
csf

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top