CODEWITHSUNDEEP
excelvba
Chris2015
Chris2015

Reputation: 1050

EntireRow.Delete performance issue

I am trying to delete all rows with blanks values. I have about 15,000 rows and no more than 25% are blank. Here is the code I have.

Columns("A:A").Select 
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete

The first and second lines of code work fine however, when I try to add the third line my spreadsheet times out and I am left with a (Not Responding) message. I think my issue is the amount of rows I am trying to delete at once because the code works when I reduce the amount of content. Can anyone suggest a fix? Why can't excel handle this?

Upvotes: 1

Views: 2641

Answers (2)

chris neilsen
chris neilsen

Reputation: 53126

The reason this takes so long is the large number of non-contiguous ranges in SpecialCells(xlCellTypeBlanks)

A better way is to sort the data before the delete, so only one contiguous range is deleted

You can then restore the original sort order after the delete, something like this:

Sub Demo()
    Dim rng As Range
    Dim rSortCol As Range
    Dim rDataCol As Range
    Dim i As Long
    Dim BlockSize As Long
    Dim sh As Worksheet
    Dim TempCol As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set sh = ActiveSheet
    Set rng = sh.UsedRange
    With rng

        ' Add a temporary column to hold a index to restore original sort
        TempCol = .Column + .Columns.Count
        Set rSortCol = .Columns(TempCol)
        rSortCol.Cells(1, 1) = 1
        rSortCol.Cells(1, 1).AutoFill rSortCol, xlFillSeries
        Set rng = rng.Resize(, rng.Columns.Count + 1)
        
        Set rDataCol = rng.Columns(1)

        ' sort on data column, so blanks get grouped together
        With sh.Sort
            .SortFields.Clear
            .SortFields.Add Key:=rDataCol, _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange rng
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        ' delete blanks (allow for possibility there are no blanks)
        On Error Resume Next
        Set rng = rDataCol.SpecialCells(xlCellTypeBlanks)
        If Err.Number <> 0 Then
            ' no blank cells
            Err.Clear
        Else
            rng.EntireRow.Delete
        End If
        On Error GoTo 0
        
        ' Restore original sort order
        With sh.Sort
            .SortFields.Clear
            .SortFields.Add Key:=rSortCol, _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange rng
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    
    End With

    ' Delete temp column
    sh.Columns(TempCol).EntireColumn.Delete

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

End Sub

My testing (on ~15000 rows, every 4th row blank) reduced time from ~20s to ~150ms

Upvotes: 3

MattCrum
MattCrum

Reputation: 1110

Your code is running on ALL rows on the spreadsheet; it would be quicker to run it on the used rows.

Something like this:

Range("A1", Cells(Sheet1.Rows.Count, 1).End(xlUp).Address).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Or, could you just sort the data range - that'd group all the blanks together...

Upvotes: 0

Related Questions