delete repeated rows

[Guest]

Hi there,

I have the code below in a sheet, deleting rows that match each other. My
problem is that this is very slow to run given that it needs to search & to
delete loads of rows.

Any ideas out there that could speed this up?


Sub DeleteRepeats()
Worksheets("Rearranged").Range("h2").Sort _
Key1:=Worksheets("Rearranged").Range("h2")
Do
Set currentCell = Worksheets("Rearranged").Range("h2")
Do While Not IsEmpty(currentCell)
Set nextCell = currentCell.Offset(1, 0)
If nextCell.Value = currentCell.Value Then
currentCell.EntireRow.Delete
End If
Set currentCell = nextCell
Loop
Loop Until nextCell = 0
End Sub

 

[Guest]

SiouxieQ,

I have found through much trial and error that the very fastest way to do
this is to:

1) Develop a formula that will evaluate each row, and let's say, place a one
in rows to keep and a zero in rows to delete. Copy this formula to all rows
in the sheet.

2) Convert the formulas created in step 1 to values.

3) Sort the sheet on the column in which the formula results reside so that
all one's and zero's are together.

4) Use FIND to locate the first and last row containing the zero's, then
select them and delete them all in one cluster.

This method may be a bit more code intensive, but it reduced one of my jobs
from over an hour to seconds (literally).

Hope this helps.

 

[Bernie Deitrick]

SiouxieQ,

Try the macro below.

HTH,
Bernie
MS Excel MVP

Sub DeleteRepeats2()
Dim myRow As Long
Worksheets("Rearranged").Activate
myRow = Range("H65536").End(xlUp).Row
Range("I1").EntireColumn.Insert
Range("I1").Value = "Flag"
Range("I2").Formula = _
"=IF(COUNTIF(H2:H" & myRow & ",H2)>1,""Delete"","""")"
Range("I2").AutoFill Destination:=Range("I2:I" & myRow)
With Range("I:I")
.AutoFilter Field:=1, Criteria1:="Delete"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
.EntireColumn.Delete
End With

End Sub

 

[Bernie Deitrick]

SiouxieQ,

Here's a better version, that turns off screenupdating and events, and sorts
prior to deletion, to speed thing up.

HTH,
Bernie
MS Excel MVP

Sub DeleteRepeats2()
Dim myRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

myRow = Range("H65536").End(xlUp).Row
Range("I1").EntireColumn.Insert
Range("I1").Value = "Flag"
Range("I2").Formula = _
"=IF(COUNTIF(H2:H" & myRow & ",H2)>1,""Delete"","""")"
Range("I2").AutoFill Destination:=Range("I2:I" & myRow)
Cells.Sort key1:=Range("I2"), order1:=xlDescending, Header:=xlYes
With Range("I:I")
.AutoFilter Field:=1, Criteria1:="Delete"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
.EntireColumn.Delete
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub