Delete whole row if the cell in the column is blank [VBA]

[Martin_H]

Hi,

I have been using this code to delete whole row if the cell in the column G is blank.

Sub DELETE_BLANKS()

Application.ScreenUpdating = False

Columns("G:G").SpecialCells(xlCellTypeBlanks).EntireRow.DELETE

Application.ScreenUpdating = True

End Sub

I have been using this macro to clean up worksheets with thousands of rows. It works well, but It takes a few minutes to run.

Is there any faster way to do the same job?

Help is much appreciated.

Many thanks.

 

[Peter_SSs]

Does this produce any measurable improvement?

Sub Del_Rows_v3()
  Dim a As Variant, b As Variant
  Dim nc As Long, lr As Long, i As Long, k As Long
 
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  lr = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  a = Range("G1:G" & lr).Value2
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If IsEmpty(a(i, 1)) Then
      b(i, 1) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With Range("A1").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
  End If
End Sub

 

[Martin_H]

Does this produce any measurable improvement?

Sub Del_Rows_v3()
  Dim a As Variant, b As Variant
  Dim nc As Long, lr As Long, i As Long, k As Long
 
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  lr = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  a = Range("G1:G" & lr).Value2
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If IsEmpty(a(i, 1)) Then
      b(i, 1) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With Range("A1").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
  End If
End Sub

Improved by 2 or 3 seconds.

Awesome!

 

[Peter_SSs]