Fast way of deleting a lot of rows

[citroendealer]

Hello fellow VBA'ers,

For a project I need to make a data set more readable. For this I need to delete 18 rows and then skip 1. This needs to be done as many elements I have in my data set. The code that is use is shown below. j is the number of elements and is prescribed within my code. The problem is that i have sometimes 2000 or 5000 elements. This takes minutes to run this part of the code. Is there a faster way?

            For i = 1 To j
                For a = 1 To 18
                    ActiveCell.EntireRow.Delete
                Next a
                Selection.Offset(1, 0).Select
            Next i

 

[citroendealer]

Hey igold,

Almost right, the problem is that it deleted the row that I wanted to keep and kept the rows that I wanted to delete.

 

[igold]

Yikes I got it backwards, try this instead...

Sub Delete19()


Dim lrow As Long


lrow = Cells(Rows.Count, 2).End(xlUp).Row
ActiveSheet.Range("B22", "B" & lrow).SpecialCells(2, 2).EntireRow.Delete
ActiveSheet.Range("B22", "B" & lrow).SpecialCells(4).EntireRow.Delete


End Sub

igold

 

[citroendealer]

Yes!!

This is exactly what I wanted and it is light years faster than what I had.

Thx ray:

 

[igold]

Well it took a try or two, and a stray comment from the peanut gallery but we got it done. Thanks for the feedback.

FYI... I used the logic that I was looking for in my initial question. Basically, after row 22, you wanted to delete any row that had did not contain a number or was blank in column B.

Regards,

igold

 

[sheetspread]

Here's the macro I posted revised for your file:

Sub DeleteAllBut19thRow()
Dim i%, lr%, lc%, a As Variant
With ActiveSheet.UsedRange
lr = .Rows.Count
lc = .Columns.Count + 1
End With
ReDim a(1 To lr)
For i = 1 To lr
If i > 23 And (i - 23) Mod 19 <> 0 Then
a(i) = 1
End If
Next
Cells(1, lc).Resize(lr).Value = Application.Transpose(a)
Application.ScreenUpdating = False
With Range("A1").Resize(lr, lc)
.Sort Key1:=.Columns(lc), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
On Error Resume Next
.Columns(lc).SpecialCells(xlConstants).EntireRow.Delete
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub

igold's specialcells method by itself should be fast enough for you, but the sort adds even more speed.