OMG_VBA_IS_GREAT
Technical User
Hi All,
The below code finds dupes and deletes the dupe(s) with the lowest number located in column "BL". The code works great for small set of data (8k rows). I am trying to use the code for over a 500,000 cells takes over three hours to run. Any help would be greatly appreciated.
Sub DeleteDups()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim sh As Worksheet, lr As Long
Sheets("A").Select
Set sh = Sheets("A")
lr = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
ColLoc = "F"
y = "BL"
For i = lr To 2 Step -1
With sh
Set fnRng = .Range(ColLoc & 2, .Cells(i - 1, y)).Find(.Cells(i, y).Value, , xlValues, xlWhole)
If Not fnRng Is Nothing Then
If fnRng.Offset(0, 58) > .Cells(i, y).Offset(0, 58) Then
.Rows(i).Delete
ElseIf fnRng.Offset(0, 58) < .Cells(i, y).Offset(0, 58) Then
fnRng.EntireRow.Delete
End If
End If
End With
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
The below code finds dupes and deletes the dupe(s) with the lowest number located in column "BL". The code works great for small set of data (8k rows). I am trying to use the code for over a 500,000 cells takes over three hours to run. Any help would be greatly appreciated.
Sub DeleteDups()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim sh As Worksheet, lr As Long
Sheets("A").Select
Set sh = Sheets("A")
lr = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
ColLoc = "F"
y = "BL"
For i = lr To 2 Step -1
With sh
Set fnRng = .Range(ColLoc & 2, .Cells(i - 1, y)).Find(.Cells(i, y).Value, , xlValues, xlWhole)
If Not fnRng Is Nothing Then
If fnRng.Offset(0, 58) > .Cells(i, y).Offset(0, 58) Then
.Rows(i).Delete
ElseIf fnRng.Offset(0, 58) < .Cells(i, y).Offset(0, 58) Then
fnRng.EntireRow.Delete
End If
End If
End With
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub