Speeding up a delete rows Macro

[QuietMan]

Below is the code I use to delete rows from a spreadsheet based on multiple
criteria. (column 16 is empty, column 2 to 15 is empty, column 1 contains
user ID)

The macro work great, but the spreadsheet is about 150K rows and it takes 15
to 20 minutes to run. I was hoping that someone would know how to make the
macro faster.

I cannot sort the data and the order is very important in the next steps...
I now delete the blank rows in column 16 one at a time, and they are some
times clustered 30 rows together...was thinking if I could modify the code to
delete blocks of rows ratther that one at a time it might speeed up the
execution

Thanks


Sub C_Remove_Blank_Rows()
Application.ScreenUpdating = False
Cells(200000, 14).Select
Selection.End(xlUp).Select
EndRow = ActiveCell.Row
Do Until EndRow < 2
If Cells(EndRow, 16) <> Empty Then GoTo No_Find
Rows(EndRow & ":" & EndRow).Select: Selection.Delete
Shift:=xlUp
GoTo No_Find2
No_Find:
Set r = Range(Cells(EndRow, 1), Cells(EndRow, 15))
r.Select
For Each r In Selection
If IsEmpty(r) Then
Else
GoTo No_Find2
Exit Sub
End If
Next
Rows(EndRow & ":" & EndRow).Select: Selection.Delete
Shift:=xlUp
GoTo No_Find3
No_Find2:
If Left(Cells(EndRow, 1), 9) <> " USER ID" Then GoTo No_Find3
Rows(EndRow & ":" & EndRow).Select: Selection.Delete
Shift:=xlUp
No_Find3:
EndRow = EndRow - 1
Loop
Application.ScreenUpdating = True
End Sub

 

[Don Guillett]

This may help.
sub delblankrowsincol16()
for i= cells(rows.count, 14).end(xlup).row to 2 step -1
if cells(i,16)="" then rows(i).delete
next i
end sub
If desired, send your file to my address below. I will only look if:
1. You send a copy of this message on an inserted sheet
2. You give me the newsgroup and the subject line
3. You send a clear explanation of what you want
4. You send before/after examples and expected results.

 

[Gary''s Student]

Don't select and then delete. Instead of:

range(.....).Select
Selection.Delete..........

use

range(.....).Delete

 

[Mike H]

Hi,

In addition turn off calculation
Application.Calculation = xlCalculationManual

code

Application.Calculation = xlCalculationAutomatic

Mike

 

[Rick Rothstein]

I'm not sure how fast the following code will be, but I'm thinking it should
be speedier than your posted code. One note though... the code assumes that
either there are no blank cells in Column A within the list of User ID
numbers or, if there are, that those rows should be deleted (as long as
columns 2 through 16 are blank as well). I also note that what you list as
two separate criteria (Column 16 is blank and Columns 2 to 15 are blank) is
really just a single condition (Columns 2 to 16 are blank). Give the macro a
try (on a **copy** of your data) and see how it works for you...

Sub DeleteEmptyData()
Dim X As Long, LastRow As Long, R As Range, Blanks As Range
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set Blanks = Range("B1:B" & LastRow).SpecialCells( _
xlCellTypeBlanks).EntireRow
For X = 2 To 16
Set R = Columns(X).SpecialCells(xlCellTypeBlanks)
Set Blanks = Intersect(R, Blanks).EntireRow
Next
Blanks.Delete
End Sub

 

[Barb Reinhardt]

I think this is what you're looking for. Test is on a COPY of your
workbook, just in case.

Option Explicit

Sub C_Remove_Blank_Rows()
Dim myRange As Excel.Range
Dim aWS As Excel.Worksheet
Dim lRow As Long
Dim i As Long
Dim myCount As Long
Dim myDeleteRange As Excel.Range
Dim r As Excel.Range
Dim myCell As Excel.Range

'Below is the code I use to delete rows from a spreadsheet based on multiple
'criteria. (column 16 is empty, column 2 to 15 is empty, column 1 contains
'user ID)
Set aWS = ActiveSheet

lRow = aWS.Cells(aWS.Rows.Count, 1).End(xlUp).Row
Set myRange = aWS.Cells(1, 1).Resize(lRow, 1)

For Each r In myRange
myCount = 0
If IsEmpty(r) Then
myCount = myCount + 1
End If
For i = 1 To 15
Set myCell = r.Offset(0, 1)
If IsEmpty(myCell) Then
myCount = myCount + 1
End If
Next i
If myCount = 16 Then
If myDeleteRange Is Nothing Then
Set myDeleteRange = r.EntireRow
Else
Set myDeleteRange = Union(myDeleteRange, r.EntireRow)
End If
End If

Next r

If Not myDeleteRange Is Nothing Then
myDeleteRange.Delete
End If

End Sub

HTH
Barb Reinhardt

 

[Barb Reinhardt]

Just realized that I didn't iterate on myCell. Replace the set MyCell line
with this

Set myCell = r.Offset(0, i)

 

[joel]

I don't know which posting to respond to. The quickest method o
deleteing rows is to add a formula into an auxillary column putt an X i
the column for row to delete. You can add the formula into row IV lik
this


Sub Macro1()


Range("IV1").Formula = "=if(A1 > 5,X,Y)"

'then copy the formula down the entire
LastRow = Range("A" & Rows.Count).End(xlUp)
Range("IV1").Copy _
Destination:=Range("IV1:IV" & LastRow)

'Next replace formula in column IV with value
Range("IV1:IV" & LastRow).Copy
Range("IV1:IV" & LastRow).PasteSpecial Paste:=xlPasteValues


'Next sort on Row IV
Rows("1:" & LastRow).Sort _
header:=xlYes, _
key1:=Range("IV1"), _
Order:=xlAscending


'Now all you have to do is delete the X's.
'asume these is a header row
Columns("IV").AutoFilter
Columns("IV").AutoFilter Field:=1, Criteria1:="X"
Rows("2:" & LastRow).SpecialCells(Type:=xlCellTypeVisible).Delete
Columns("IV").Delete
End Sub
this may seem like a lot of steps, but it is the quickest metho