how to suppress efficiently all empty rows in selected columns in excel vba?

user_1344633 0
Viewed 114

I have found some Q/A to delete rows with empty cells in a chosen column like here. My need is a bit different, the columns are selected by the user, but this is not important.

EDIT : what is important in my use case is to delete the rows where all the cells are empty for these columns i.e. the selected columns.

The following code is working, but can only process 1,000 lines per minute on my i5. In my use case, the datasheet contains several 100k lines which means hours to process. This is not acceptable. Is there a trick to perfom it quickly please?

Sub DeleteRowsOfEmptyColumn() 'sh As Worksheet, col As String)
    Application.ScreenUpdating = False
    Dim sh As Excel.Worksheet: Set sh = ActiveWorkbook.ActiveSheet
    Dim col As Range: Set col = Selection.EntireColumn
    Dim cell
    Dim area As Range: Set area = Intersect(sh.UsedRange, col)
    For i = area.Rows.Count To 1 Step -1 'For Each row In area.Rows
        fKeep = False
        For Each cell In area.Rows(i).Cells
            If Not IsEmpty(cell) Then
                fKeep = True
                Exit For
            End If
        Next cell
        If Not fKeep Then
            sh.Rows(i).Delete 'rowsToDelete.Add i
        End If
    Next i  
    Application.ScreenUpdating = True
End Sub

Example:

Before:

enter image description here

After:

enter image description here

rows vba excel optimization loops
3 Answers

Delete Empty Row Ranges

  • This is a basic example. Your feedback regarding the efficiency is appreciated.
Option Explicit

Sub DeleteRowsOfEmptyColumn()
    
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve
    Dim crg As Range: Set crg = Selection.EntireColumn ' Columns Range
    Dim srg As Range: Set srg = Intersect(ws.UsedRange, crg) ' Source Range
    
    Dim drg As Range ' Delete Range
    Dim arg As Range ' Area Range
    Dim rrg As Range ' Row Range
    
    For Each arg In srg.Areas
        For Each rrg In arg.Rows
            If Application.CountA(rrg) = 0 Then
                If drg Is Nothing Then
                    Set drg = rrg
                Else
                    Set drg = Union(drg, rrg)
                End If
            End If
        Next rrg
    Next arg
    
    If Not drg Is Nothing Then drg.Delete
    
    Application.ScreenUpdating = True

    MsgBox "Rows deleted.", vbInformation

End Sub
user_98140690

Please, try the next way. It will process selected columns or columns having at least a selected cell. It will delete entire rows of the sheet, for the cases of all selected columns empty rows. The code only selects the rows in discussion. If they are the appropriate ones, on the last code line, Select should be replaced with Delete. It should be very fast, even for larger ranges, iterating only between blank cells range:

Sub DeleteRowsOfEmptyColumnsCells()
    Dim sh As Excel.Worksheet: Set sh = ActiveSheet
    Dim col As Range: Set col = Selection.EntireColumn
    Dim area As Range: Set area = Intersect(sh.UsedRange, col)
    Dim firstCol As Long: firstCol = area.Column: Stop
    Dim areaV As Range, arr, rngDel As Range, i As Long
    On Error Resume Next 'only for the case of no any empty rows existence
     Set areaV = area.SpecialCells(xlCellTypeBlanks) 'a range of only empty cells
    On Error GoTo 0
    
    arr = getRows(areaV) 'extract all rows and number of columns
    For i = 0 To UBound(arr(0)) 'iterate between all existing rows
       If Intersect(sh.rows(arr(0)(i)), areaV).cells.count = arr(1) Then
            If rngDel Is Nothing Then
                Set rngDel = sh.cells(arr(0)(i), firstCol)
            Else
                Set rngDel = Union(rngDel, sh.cells(arr(0)(i), firstCol))
            End If
       End If
    Next i
    If Not rngDel Is Nothing Then rngDel.EntireRow.Select 'if it looks OK, Select should be replaced with Delete
End Sub

Function getRows(rng As Range) As Variant
  Dim A As Range, i As Long, countC As Long
  Dim arrCol, arrR, k As Long, R As Long, mtchC, mtchR
  ReDim arrCol(rng.cells.count): ReDim arrR(rng.cells.count)
  For Each A In rng.Areas
        For i = 1 To A.Columns.count
            For j = 1 To A.rows.count
                mtchC = Application.match(A.cells(j, i).Column, arrCol, 0)
                mtchR = Application.match(A.cells(j, i).row, arrR, 0)
                If IsError(mtchC) Then
                    arrCol(k) = A.cells(j, i).Column: k = k + 1
                End If
                If IsError(mtchR) Then
                    arrR(R) = A.cells(j, i).row: R = R + 1
                End If
            Next j
        Next i
  Next A
  ReDim Preserve arrR(R - 1)
  getRows = Array(arrR, k)
End Function
user_22333080

I am working on similar kind of project. I have chosen to read the data into an array, and then work with the data in the array which improves run time significantly. Here is a copy of the function that I have used to delete / transform the data set:

    Option Explicit
Option Base 1
Public Function RemoveRowFromArray(Arr As Variant, Element As String, Col As Long) As Variant

Dim i, j, c, count As Long
Dim TempArr() As Variant

    For i = LBound(Arr, 1) To UBound(Arr, 1)                         ' looping through the columns to get desired value
        If Arr(i, Col) = Element Then
             count = count + 1                                                   ' Counting the number of Elements in array / matrix
                    For j = i To (UBound(Arr, 1) - 1)                       ' Looping from the row where Element is found
                        For c = LBound(Arr, 2) To UBound(Arr, 2)    ' Moving all elements in row 1 row up
                                Arr(j, c) = Arr(j + 1, c)
                        Next c
                    Next j
        End If
    Next i
    
    ' Populating TempArr to delete the last rows

ReDim TempArr((UBound(Arr, 1) - count), UBound(Arr, 2))

   For i = LBound(TempArr, 1) To UBound(TempArr, 1)
            For j = LBound(TempArr, 2) To UBound(TempArr, 2)
                    TempArr(i, j) = Arr(i, j)                                                 
            Next j
    Next i

    RemoveRowFromArray = TempArr
End Function

I tested this and seems to work perfectly. A few important matters to keep in mind

Option Base 1 - This is important, when you declare an arr in VBA it starts at Index 0, when you read the arr from a data set in Excel [arr = sheet1.Range("A:D")] then the arr starting index is 1, Option Base 1 will ensure that all arr start at Index 1.

The function variables are : Arr - the array / matrix

Element - the string that you wish to search for (in your case it would be blank)

Col - is the column number in which Element is.

user_151552780
Related