Speed up code Removing duplicate rows

[Ixtreme]

I have a sheet with more than 4,000 rows which is expanding).

Column D contains dates
Column E contains employees
Column F contains ordernumber

After running a VBA script that appends rows to my sheet, I want to
remove rows where Column D and Column E are equal while column F is
empty. Currently I have received a script from Joel, but this takes
more than 10 minutes to finish. Is there a better / quicker way to do
what I want?


Sub Removed_Duplicates()

LastRow = Cells(Rows.Count, "D").End(xlUp).Row

Remove = False
LoopCounter = 1
Do While LoopCounter <= LastRow
If IsEmpty(Cells(LoopCounter, "F")) Then

MyDate = Cells(LoopCounter, "D").Value
Employee = Cells(LoopCounter, "E").Value

For RowCount = 1 To LastRow
If RowCount <> LoopCounter Then

If (Cells(RowCount, "D").Value = MyDate) And _
(Cells(RowCount, "E").Value = Employee) Then

Remove = True
End If

End If

Next RowCount

End If

If Remove = True Then
Rows(LoopCounter).Delete
Remove = False
Else
LoopCounter = LoopCounter + 1
End If
Loop
End Sub

 

[Guest]

One of the fastest ways would be to program the Autofilter.

See here for the basis of the code:

http://www.contextures.com/xlautofilter03.html

 

[Guest]

Main thing is to turn off screen updating and if you have formulas there turn
off calculations, try this:

Sub Removed_Duplicates()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


LastRow = Cells(Rows.Count, "D").End(xlUp).Row

Remove = False
LoopCounter = 1
Do While LoopCounter <= LastRow
If IsEmpty(Cells(LoopCounter, "F")) Then

MyDate = Cells(LoopCounter, "D").Value
Employee = Cells(LoopCounter, "E").Value

For RowCount = 1 To LastRow
If RowCount <> LoopCounter Then

If (Cells(RowCount, "D").Value = MyDate) And _
(Cells(RowCount, "E").Value = Employee) Then

Remove = True
End If

End If

Next RowCount

End If

If Remove = True Then
Rows(LoopCounter).Delete
Remove = False
Else
LoopCounter = LoopCounter + 1
End If
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub