For Loop Taking Too Long

[Peter.Stevens2]

Hi, I've got a sheet which I need to analyse and split into several different sheets but the raw data format leaves a lot to be desired as there are blank rows inserted randomly between rows of data. I need the 'good' data to stay in the same order so I've written a macro to sort through the data and delete any blank rows leaving the good stuff behind. The problem is this takes ages as there can be up to 30000 rows that need to be checked and I need to do this 5-6 times a day. I just wondered weather there was a quicker way to do this? The code I've got is detailed below:

Sub Prep2()
'Delete all blank data rows
Dim Rows As Double
Dim Rownum As Double
Application.ScreenUpdating = False
Rows = Selection.SpecialCells(xlLastCell).Row
 
For Rownum = 2 To Rows
    If Cells(Rownum, 11) <> "" Then GoTo NxtRownum Else
 
    Cells(Rownum, 11).EntireRow.Delete shift:=xlUp
 
    Rows = Rows - 1
NxtRownum:
Next Rownum
Application.ScreenUpdating = True
End Sub

Many Thanks for any help you can offer!

 

[Peter.Stevens2]

Richard, Thanks for the suggestion, I tried it but it deletes the whole lot, I don't hink I'll be able to use Autofilter due to the potential number of lines in the sheet.

Thanks Ragnar I'll try the Lenb approach to see if thats faster.

 

[Boller]

Try :-

[K:K] = [K:K].Value
On Error Resume Next
[K:K].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

 

[Richard Schollar]

The number of rows won't affect Autofilter. This amendment might work better:

Sub DeleteRows()
Dim r As Range
Rows(1).Insert
[K1] = "Header"
Set r = Application.Intersect(ActiveSheet.UsedRange,Range("K:K"))
r.Autofilter Field:=1,Criteria1:=""
r.EntireRow.Delete
End Sub

 

[Peter.Stevens2]

Thanks Richard, I think there may be something odd about the way the raw data is constructed, any autofilter approaches I try delete's all of the data on the sheet, even If I try to do it manually. It's a downloaded tab delimited text file from SAP and I've had problems with these downloads before. I've tried transferring the data onto a genuine excel work book but it's had no effect.

 

[Ragnar1211]

Sounds like the blank cells actually have a value of "" instead of being blank.

That would explain why the faster solutions have not worked for you.

 

[Peter.Stevens2]

That makes sense, I'll just have to use the slower 'go through every line' method, it's not too bad now it's running a lot faster. Thakns for your help.

 

[Boller]

Did you try my suggestion?

 

[Peter.Stevens2]

Hi Boller, Thanks for your suggestion. I did, but the raw data sheet I am using is a tab delimited text file and the macro deletes the whole raw data sheet rather than just the empty cells. I'm not quite sure why this is.

 

[Boller]

This may be quicker, depending upon the make-up of your data :-

Dim rng As Range
Application.ScreenUpdating = False
Columns(1).Insert
Set rng = Range([A2], Cells(ActiveSheet.UsedRange.SpecialCells(xlLastCell).Row, 1))
With rng
    .FormulaR1C1 = "=IF(RC[11]="""",""d"",1)"
    .EntireRow.Sort Key1:=[A2], Order1:=xlAscending, Header:=xlNo
    On Error Resume Next
    .SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete
    On Error GoTo 0
End With
Columns(1).Delete
Application.ScreenUpdating = True

 

[Legacy 14611]

My experience is that deleting rows (by shifting nondeleted rows up one at a time) is inevitably a slow task.
You might like to check the following code to see if it's adequate for your purposes.
Excel timer included so you can check how long it takes.
Also included is code generating test data which I think is on the lines you described, so you can test it first.

Sub deleteit()
t = Timer
Dim a, n As Long, m As Integer, c()
Dim i As Long, j As Long, p As Long
a = ActiveSheet.UsedRange
n = UBound(a, 1): m = UBound(a, 2)
ReDim c(1 To n, 1 To m)
For i = 1 To n
    If Not IsEmpty(a(i, 11)) Then
        p = p + 1
        For j = 1 To m: c(p, j) = a(i, j): Next j
    End If
Next i
ActiveSheet.UsedRange.ClearContents
Cells(1, 1).Resize(p, m) = c
MsgBox "Time taken was " & format(timer - t, "0.00") & " secs"
End Sub

Sub testdata()
Dim t, x
t = Timer
With Range("a1:z30000")
    .Value = "=int(rand()*4)"
    .Value = .Value
   x = .Columns("k").Replace(0, Empty)
End With
End Sub