How to speed up vba code that delete rows when column Q has blank cells-CodePudding

I have a sheet of almost 100000 rows & column A to Q I have a code that delete entire rows if column Q has blank cells.

I have tried this code on 4000 rows it is running in 3 minutes but when I take 100000 rows it just processing for hours.

I will be very great full if some help/guide me in speeding up this code.

The code is :

Sub DeleteBlank()
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual 
    
    Dim lo As ListObject
    set lo = sheets("BOM 6061").ListObjects(1)
    Sheets("BOM 6061").Activate
    
    lo.AutoFilter.ShowAllData
    lo.range.AutoFilter Field:=17, Criteria1:=""
    
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationAutomatic
    
    lo.DataBodyRange.SpecialCells(xlCellsTypeVisible).Delete
    
    Application.DisplayAlerts = True
    lo.AutoFilter.ShowAllData
End Sub

CodePudding user response：

I had an simple example of this from a while ago. Advanced filtering is the fastest way to filter in place or to filter and copy in excel/vba. In advanced filtering you usually have your filters listed out in columns/rows and can have as many as you need, use >"" for filtering out blanks on a column, should take no time at all. In my example it might be different as this was used alongside sheetchange to autofilter if anything was added to the filters.

Sub Advanced_Filtering_Mod()

Dim rc As Long, crc As Long, trc As Long

On Error Resume Next
Sheet1.ShowAllData: rc = Sheet1.Range("A" & Rows.Count).End(xlUp).Row: crc = Sheet1.Range("G7").End(xlUp).Row
trc = Sheet1.Range("H7").End(xlUp).Row: If trc > crc Then crc = trc
trc = Sheet1.Range("I7").End(xlUp).Row: If trc > crc Then crc = trc
trc = Sheet1.Range("J7").End(xlUp).Row: If trc > crc Then crc = trc
trc = Sheet1.Range("K7").End(xlUp).Row: If trc > crc Then crc = trc

Sheet1.Range("A8:V" & rc).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Sheet1.Range("G2:K" & crc)

End Sub

CodePudding user response：

I would not use an Autofilter on large data sets as they can take quite a bit of time trying to enumerate the available options before actually filtering the data. The AutoFilter.ShowAllData takes just as much time. For my super simple test dataset, which consisted of 26 columns of 1000000 rows, it took 30 seconds for each to process.

From what I can tell you are filtering the list to show only the blank items and then deleting the blank rows. Since the filtering is what is causing the delay we could just loop through each row looking at a specific column and if it is blank you can just delete it. Below is an example of how to do this.

**Edit: After testing I found this to be much slower than what you would want. Check out the next example below as it is super fast.

Option Explicit

Sub DeleteBlank()

    Application.ScreenUpdating = False

    Dim calcType As Integer
    Dim rowCount, columnNumToCheck, currow, dataStartRow As Long
    Dim WkSht As String
    Dim lo As ListObject

    WkSht = "BOM 6061" 'The name of the worksheet where the table is located.
    columnNumToCheck = 17 'The column number to check for blank cells.

    calcType = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set lo = Sheets(WkSht).ListObjects(1)
    rowCount = lo.ListRows.Count
    dataStartRow = (lo.DataBodyRange.Row - 1)

    For currow = rowCount To 1 Step -1
        If Sheets(WkSht).Cells((currow   dataStartRow), columnNumToCheck).Value = "" Then
            Call DeleteRows(WkSht, (currow   dataStartRow))
        End If
    Next currow

    Application.Calculation = calcType
    Application.ScreenUpdating = True

End Sub

Private Sub DeleteRows(sheetNameIn As String, startRow As Long, Optional optionalEndRow As Long)

    If IsNull(optionalEndRow) Or optionalEndRow = 0 Then
        optionalEndRow = startRow
    End If

    Worksheets(sheetNameIn).Range(startRow & ":" & optionalEndRow).Delete Shift:=xlUp

End Sub

If you are able to sort your data where the blank cells are all together you could use the below to perform a single delete function remove them all at once. This deleted 70000 rows in a few seconds.

Sub DeleteBlankWithSort()

    'Application.ScreenUpdating = False

    Dim columnNumToCheck, tableLastRow, lrow As Long
    Dim calcType As Integer
    Dim WkSht As String
    Dim lo As ListObject

    WkSht = "BOM 6061" 'The name of the worksheet where the table is located.
    columnNumToCheck = 17 'The column number to check for blank cells.

    calcType = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set lo = Sheets(WkSht).ListObjects(1)
                  
    tableLastRow = FindLastRow(WkSht, (columnNumToCheck))
    
    With lo.Sort
        .SortFields.Clear
        .SortFields.Add _
            Key:=Range("Table1[[#All],[q]]"), _
            SortOn:=xlSortOnValues, _
            Order:=xlDescending, _
            DataOption:=xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    lrow = FindLastRow(WkSht, (columnNumToCheck), (tableLastRow))
    Call DeleteRows(WkSht, (tableLastRow), (lrow   1))

    Application.Calculation = calcType
    Application.ScreenUpdating = True

End Sub

Private Sub DeleteRows(sheetNameIn As String, startRow As Long, Optional optionalEndRow As Long)

    If IsNull(optionalEndRow) Or optionalEndRow = 0 Then
        optionalEndRow = startRow
    End If

    Worksheets(sheetNameIn).Range(startRow & ":" & optionalEndRow).Delete Shift:=xlUp

End Sub

Private Function FindLastRow(sheetNameIn As String, columnNum As Long, Optional optionalStartRow As Long) As Long
'finds the last row of the column passed in the sheetname passed in
    
    If IsNull(optionalStartRow) Or optionalStartRow = 0 Then
        optionalStartRow = 1048576
    End If
    
    FindLastRow = Worksheets(sheetNameIn).Range(Cells(optionalStartRow, columnNum).Address).End(xlUp).Row
    
End Function