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.

 

[footoo]

Try adding code at the start of the macro to sort the data so that the blank cells are at the bottom.
If you need help adding the code to do this, post again.

 

[Martin_H]

Thanks for the reply footoo, I would like to see your code.

 

[Peter_SSs]

Give this a try with a copy of your data.
I have assumed headers in row 1.

Sub Del_Rows()
  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("G2: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
    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

 

[Martin_H]

Hi Peter, thank you for your reply.

Well there are no actual headers. It is a messy worksheet like a Swiss cheese with a lot of blank rows and columns.

 

[footoo]

Peter_SSs's code should a bit quicker, but you could try this :

Sub Del_Rows()
Dim nc As Long, lr 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
Application.ScreenUpdating = False
With Range(Cells(1, nc), Cells(lr, nc))
    .Formula = "=IF(G1="""",""d"",1)"
    .EntireRow.Sort Key1:=Columns(nc), Order1:=xlAscending, Header:=xlNo
End With
Columns(nc).Delete
[G:G].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

 

[Martin_H]

Peter_SSs's code should a bit quicker, but you could try this :

Sub Del_Rows()
Dim nc As Long, lr 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
Application.ScreenUpdating = False
With Range(Cells(1, nc), Cells(lr, nc))
    .Formula = "=IF(G1="""",""d"",1)"
    .EntireRow.Sort Key1:=Columns(nc), Order1:=xlAscending, Header:=xlNo
End With
Columns(nc).Delete
[G:G].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Thank you for your reply footoo.

Macro worked but it took way longer than the original one.

 

[Peter_SSs]

Well there are no actual headers.

Then there are just a couple of small changes.

Sub Del_Rows_v2()
  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
    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.ScreenUpdating = True
  End If
End Sub

 

[Martin_H]

Thank you for your reply footoo.

Macro worked but it took way longer than the original one.

I am sorry, I made a mistake.

It is way faster now!

 

[Martin_H]

Then there are just a couple of small changes.

Sub Del_Rows_v2()
  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
    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.ScreenUpdating = True
  End If
End Sub

Worked!

Original code took more than 150 seconds.

With footoo's code it took aprox 18 seconds.
With Peter's code it took aprox 16 seconds.

Awesome guys! You saved me a lot of time.

Thank you very much. Much appreciated.