Deleting empty rows fastest way possible

[adnan1975]

I am sure this has been discussed many times before but here it is again. I am trying to delete empty rows from a spreadsheet with more than 10000 rows. I am using the following code but it doesn't work.

Sub RowDeleter()
    Dim sht As Worksheet
    Dim r As Long
    Dim EndRow As Long
    Dim TCount As Long
    Dim s As Date
    Dim e As Date

    Application.ScreenUpdating = True
    r = 2       'Initialise row number
    s = Now     'Start Time
    Set sht = ActiveSheet
    EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row

    'Check if "Test String" is found in Column 1
    TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "")
    If TCount > 0 Then

        'loop through to the End row
        While r <= EndRow
            If InStr(sht.Cells(r, 1).Text, "") > 0 Then
                sht.Rows(r).Delete Shift:=xlUp
                r = r - 1
            End If
            r = r + 1
        Wend
    End If
    e = Now  'End Time
    D = (Hour(e) * 360 + Minute(e) * 60 + Second(e)) - (Hour(s) * 360 + Minute(s) * 60 + Second(s))
    Application.ScreenUpdating = True
    DurationTime = TimeSerial(0, 0, D)
    MsgBox Format(DurationTime, "hh:mm:ss")
End Sub

Segment	Country	Product	Discount Band	Units Sold	Manufacturing Price	Sale Price	Gross Sales	Discounts
Government	Canada	Carretera	None	1618.5​	$ 3.00	$ 20.00	$ 32,370.00	$ -
Government	Germany	Carretera	None	1321​	$ 3.00	$ 20.00	$ 26,420.00	$ -
Midmarket	France	Carretera	None	2178​	$ 3.00	$ 15.00	$ 32,670.00	$ -
Midmarket	Germany	Carretera	None	888​	$ 3.00	$ 15.00	$ 13,320.00	$ -
Midmarket	Mexico	Carretera	None	2470​	$ 3.00	$ 15.00	$ 37,050.00	$ -
Government	Germany	Carretera	None	1513​	$ 3.00	$ 350.00	$ 529,550.00	$ -
Midmarket	Germany	Montana	None	921​	$ 5.00	$ 15.00	$ 13,815.00	$ -
Channel Partners	Canada	Montana	None	2518​	$ 5.00	$ 12.00	$ 30,216.00	$ -
Government	France	Montana	None	1899​	$ 5.00	$ 20.00	$ 37,980.00	$ -
Channel Partners	Germany	Montana	None	1545​	$ 5.00	$ 12.00	$ 18,540.00	$ -
Midmarket	Mexico	Montana	None	2470​	$ 5.00	$ 15.00	$ 37,050.00	$ -
Enterprise	Canada	Montana	None	2665.5​	$ 5.00	$ 125.00	$ 333,187.50	$ -
Small Business	Mexico	Montana	None	958​	$ 5.00	$ 300.00	$ 287,400.00	$ -
Government	Germany	Montana	None	2146​	$ 5.00	$ 7.00	$ 15,022.00	$ -
Enterprise	Canada	Montana	None	345​	$ 5.00	$ 125.00	$ 43,125.00	$ -
Midmarket	United States of America	Montana	None	615​	$ 5.00	$ 15.00	$ 9,225.00	$ -
Government	Canada	Paseo	None	292​	$ 10.00	$ 20.00	$ 5,840.00	$ -
Midmarket	Mexico	Paseo	None	974​	$ 10.00	$ 15.00	$ 14,610.00	$ -
Channel Partners	Canada	Paseo	None	2518​	$ 10.00	$ 12.00	$ 30,216.00	$ -
Government	Germany	Paseo	None	1006​	$ 10.00	$ 350.00	$ 352,100.00	$ -
Channel Partners	Germany	Paseo	None	367​	$ 10.00	$ 12.00	$ 4,404.00	$ -
Government	Mexico	Paseo	None	883​	$ 10.00	$ 7.00	$ 6,181.00	$ -

Any help is highly appreciated.
I tried to use L2BB add in but it is blocked by excel and dont know how to unlock it.

 

[Michael M]

Maybe this way

Sub Del_Rows()
  On Error Resume Next
  Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlBlanks).EntireRow.Delete
End Sub

 

[adnan1975]

Maybe this way

Sub Del_Rows()
  On Error Resume Next
  Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlBlanks).EntireRow.Delete
End Sub

thank you for quick reply. It worked.

 

[Michael M]

Glad to help..

 

[Peter_SSs]

I tried to use L2BB add in but it is blocked by excel and dont know how to unlock it.

Look at these:
Xl2bb got disable
xl2bb

Deleting empty rows fastest way possible

spreadsheet with more than 10000 rows.

With your sample data copied down 10,000 rows, on my machine ..

Post 3 code: 2.7 seconds
Below code: 0.06 seconds (ie 45 x faster)

Sub Del_Empty()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long

  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If Len(a(i, 1)) = 0 Then
      b(i, 1) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A2").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub

 

[jolivanes]

Both without sorting, on a 15 yr old laptop, with 11,000 rows.
Assumed Columns A to I.

1.3 seconds for following

Sub Or_So_Maybe()
Dim dataArr, i As Long, rng As Range
dataArr = Sheets("Sheet1").Range("A1:I" & Cells(Rows.Count, 9).End(xlUp).Row).Value
    For i = 2 To UBound(dataArr)
        If dataArr(i, 1) = 0 Then
            If Not rng Is Nothing Then
                Set rng = Union(rng, Cells(i, 1).EntireRow)
                    Else
                Set rng = Cells(i, 1).EntireRow
            End If
        End If
    Next i
If Not rng Is Nothing Then rng.Delete Shift:=xlUp
Set rng = Nothing
End Sub

and 0.2 seconds for following (here pasted in another sheet)

Sub Or_So_Maybe_2()
Dim dataArr1, dataArr2(), i As Long, j As Long, k As Long
j = 1
dataArr1 = Sheets("Sheet1").Range("A1:I" & Cells(Rows.Count, 9).End(xlUp).Row).Value
'MsgBox UBound(dataArr1, 2)
ReDim Preserve dataArr2(1 To UBound(dataArr1, 1), 1 To UBound(dataArr1, 2))
    For i = 1 To UBound(dataArr1)
        If Not dataArr1(i, 1) = "" Then
            For k = 1 To UBound(dataArr1, 2)
                dataArr2(j, k) = dataArr1(i, k)
            Next k
        j = j + 1
        End If
    Next i
Sheets("Sheet4").Cells(1, 1).Resize(UBound(dataArr2, 1), UBound(dataArr2, 2)) = dataArr2
End Sub

 

[Peter_SSs]

1.3 seconds for following

and 0.2 seconds for following (here pasted in another sheet)

Without comparison to the other codes using the same data on the same machine, the numbers themselves don't mean much.

For me, on the same data I used earlier, your first code took 4.031 seconds.
The second code took 0.164 seconds. This is not directly comparable since it is not actually deleting rows and any formulas & some types of formatting would be lost. Whether that is relevant to the OP we don't know.

In any case, with my tests, it was still about 3 times slower than the post 5 code so for me wouldn't qualify for the fastest way. It may be different for you as I have found differences like that reported by members in the past.

 

[jolivanes]

Hi Peter.
A top of the morning (I think in your part of the world) to you.
I just wanted to see what different ways of attacking the problem would do because I saw that times were published..
It is not in any way an attempt to be faster then the next person, just a comparison doing it different.
As you mentioned, the 2nd code's time will be different if deleting the existing data is incorporated.

 

[Peter_SSs]

A top of the morning (I think in your part of the world) to you.

No, latish afternoon actually (about 5:30 pm) but thanks anyway.

Understand what you are saying though I would be interested to see the results if you timed the other codes since, as I mentioned, sometimes in the past other members have reported different codes as fastest/slowest compared to my timings.

 

[jolivanes]

I will tomorrow Peter because it is way past my beauty sleep time (midnight)