I
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
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