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

--
Rick (MVP - Excel)


"QuietMan" wrote in message
...
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

--
Helping Is always a good thing