Possible to make this macro faster?

[ste33uka]

Hi could anyone make this macro faster for deleting rows?
The macro deletes rows if cells R to P are blank
Currently it is taking 15 minutes to do 1000 rows.
Thanks

Sub DeleteRows()
Dim x As Long, LastRow As Long, cRange As Range
LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Set cRange = Range("R1:P" & LastRow)
For x = cRange.Cells.Count To 1 Step -1
    With cRange.Cells(x)
        If Application.WorksheetFunction.CountIf(Range("p" & .Row & ":" & "r" & .Row), "") = 3 Then
            .EntireRow.Delete
        End If
    End With
Next x
MsgBox "Complete"
End Sub

 

[Alex Blakenburg]

See if this helps enough.
By looping through cells from P:R, you are looping 3x as many times as you need to.
I am also hoping the CountBlank is faster than Countifs.

Sub DeleteRows()
    Dim x As Long, LastRow As Long, cRange As Range
    LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
    Set cRange = Range("R1:P" & LastRow)
    For x = LastRow To 1 Step -1
            If Application.WorksheetFunction.CountBlank(Range("p" & x & ":" & "r" & x)) = 3 Then
                Cells(x, 4).EntireRow.Delete
            End If
    Next x
    MsgBox "Complete"
End Sub

 

[Macropod]

Try:

Sub DeleteRows()
Application.ScreenUpdating = False
Dim r As Long, c As Long, i As Long
With ActiveSheet
  For r = .Cells(Rows.Count, "D").End(xlUp).Row To 1 Step -1
    i = 0
    For c = 16 To 18
      i = i + (.Cells(r, c).Value <> "")
    Next
    If i = 0 Then .Rows(r).EntireRow.Delete
  Next
End With
Application.ScreenUpdating = True
MsgBox "Complete"
End Sub

 

[HaHoBe]

Hi ste33uka,

turn the Screenupdating off and there should be a sped boost. Based on Alex code I altered Calculation to maual as well and build a range instead of deleting each single row:

Sub DeleteRows_120521()
'https://www.mrexcel.com/board/threads/possible-to-make-this-macro-faster.1170700
  Dim x As Long, cRange As Range, lngCalc As Long
 
  Application.ScreenUpdating = False
  lngCalc = Application.Calculatiom
  Application.Calculation = xlCalculationManual
 
  For x = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row To 1 Step -1
    If Application.WorksheetFunction.CountBlank(Range("p" & x).Resize(1, 3)) = 3 Then
      If cRange Is Nothing Then
        Set cRange = Cells(x, 4)
      Else
        Set cRange = Union(Cells(x, 4), cRange)
      End If
    End If
  Next x
 
  If Not cRange Is Nothing Then
    cRange.EntireRow.Delete
    Set cRange = Nothing
  End If
  Application.Calculation = lngCalc
  Application.ScreenUpdating = True
 
  MsgBox "Complete"
End Sub

Ciao,
Holger

 

[HaHoBe]

Hi ste33uka,

using SpecialCells if the cells are really blanks:

Sub DeleteRows_120521_mod2()
'https://www.mrexcel.com/board/threads/possible-to-make-this-macro-faster.1170700
  Dim x As Long, cRange As Range, lngCalc As Long, rng As Range
 
  Application.ScreenUpdating = False
  lngCalc = Application.Calculatiom
  Application.Calculation = xlCalculationManual
 
  On Error Resume Next
  Set cRange = Range("P1", Cells(Cells(Rows.Count, "D").End(xlUp).Row, "P")).SpecialCells(xlCellTypeVisible)
  On Error GoTo 0
  If Not cRange Is Nothing Then
    For Each rng In cRange
      If Application.WorksheetFunction.CountBlank(cRange.Resize(1, 3)) = 3 Then
        cRange.EntireRow.Delete
      End If
    End If
  End If
  Set cRange = Nothing
 
  Application.Calculation = lngCalc
  Application.ScreenUpdating = True
 
  MsgBox "Complete"
End Sub

If the code still uses a lot of time: are there any events in ThisWorkbook or behind the sheets that fire events?

Have you thought about using AutoFilter for this (could be a non-VBA solution)?

Ciao,
Holger

 

[ste33uka]

Try:

Sub DeleteRows()
Application.ScreenUpdating = False
Dim r As Long, c As Long, i As Long
With ActiveSheet
  For r = .Cells(Rows.Count, "D").End(xlUp).Row To 1 Step -1
    i = 0
    For c = 16 To 18
      i = i + (.Cells(r, c).Value <> "")
    Next
    If i = 0 Then .Rows(r).EntireRow.Delete
  Next
End With
Application.ScreenUpdating = True
MsgBox "Complete"
End Sub

thanks but still takes over 15 minutes

 

[Norie]

Build up the range to delete then to the deletion after the loop.

Sub DeleteRows()
Dim rngToDelete As Range
Dim x As Long, LastRow As Long, cRange As Range

    LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
    Set cRange = Range("R1:P" & LastRow)
    
    For x = cRange.Cells.Count To 1 Step -1
        With cRange.Cells(x)
            If Application.WorksheetFunction.CountIf(Range("p" & .Row & ":" & "r" & .Row), "") = 3 Then
                If rngToDelete Is Nothing Then
                    Set rngToDelete = .EntireRow
                Else
                    Set rngToDelete = Union(rngToDelete, .EntireRow)
                End If
            End If
        End With
    Next x

    If Not rngToDelete Is Nothing Then
        rngToDelete.Delete
    End If
    
    MsgBox "Complete"
    
End Sub

 

[ste33uka]

Hi ste33uka,

using SpecialCells if the cells are really blanks:

Sub DeleteRows_120521_mod2()
'https://www.mrexcel.com/board/threads/possible-to-make-this-macro-faster.1170700
  Dim x As Long, cRange As Range, lngCalc As Long, rng As Range
 
  Application.ScreenUpdating = False
  lngCalc = Application.Calculatiom
  Application.Calculation = xlCalculationManual
 
  On Error Resume Next
  Set cRange = Range("P1", Cells(Cells(Rows.Count, "D").End(xlUp).Row, "P")).SpecialCells(xlCellTypeVisible)
  On Error GoTo 0
  If Not cRange Is Nothing Then
    For Each rng In cRange
      If Application.WorksheetFunction.CountBlank(cRange.Resize(1, 3)) = 3 Then
        cRange.EntireRow.Delete
      End If
    End If
  End If
  Set cRange = Nothing
 
  Application.Calculation = lngCalc
  Application.ScreenUpdating = True
 
  MsgBox "Complete"
End Sub

If the code still uses a lot of time: are there any events in ThisWorkbook or behind the sheets that fire events?

Have you thought about using AutoFilter for this (could be a non-VBA solution)?

Ciao,
Holger

I get debug error with that code

 

[ste33uka]

Build up the range to delete then to the deletion after the loop.

Sub DeleteRows()
Dim rngToDelete As Range
Dim x As Long, LastRow As Long, cRange As Range

    LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
    Set cRange = Range("R1:P" & LastRow)
   
    For x = cRange.Cells.Count To 1 Step -1
        With cRange.Cells(x)
            If Application.WorksheetFunction.CountIf(Range("p" & .Row & ":" & "r" & .Row), "") = 3 Then
                If rngToDelete Is Nothing Then
                    Set rngToDelete = .EntireRow
                Else
                    Set rngToDelete = Union(rngToDelete, .EntireRow)
                End If
            End If
        End With
    Next x

    If Not rngToDelete Is Nothing Then
        rngToDelete.Delete
    End If
   
    MsgBox "Complete"
   
End Sub

still takes over minutes
dont think i will be a solutiion for this one

 

[Peter_SSs]

My testing shows this at least 8x faster than the other valid codes suggested (posts #4 & 5 are not valid codes)

Sub DelIfPtoRBlank()
  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("P1:R" & lr).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If Len(a(i, 1)) = 0 Then
      If Len(a(i, 2)) = 0 Then
        If Len(a(i, 3)) = 0 Then
          b(i, 1) = 1
          k = k + 1
        End If
      End If
    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