Clear rows with an empty cell in column A, without deleting entire row takes a very long time-CodePudding

This code is a part of a larger macro.

Sub testremoveBlankRows()

Dim rng8        As Range
Dim cell        As Range
'------------------------------
'Start Timer
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'-------------------------------------------------
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .EnableEvents = False
    .CutCopyMode = False
End With
'--------------------------------------------------
ActiveSheet.UsedRange
On Error Resume Next
Set rng8 = Columns("A").SpecialCells(xlBlanks)
On Error GoTo 0

If rng8 Is Nothing Then Exit Sub
    For Each cell In rng8.Areas
        cell.Cells(1).Offset(0, 0).Resize(cell.Rows.count, 24).Delete xlUp
    Next cell
'-------------------------------------------------------------
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .EnableEvents = True
    .CutCopyMode = False
End With
'-------------------------------------------------------------
'Stop Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
'-------------------------------------
End Sub

This piece of code takes about 85 seconds to run (Sheet1), if I use it in the macro. If I run code separately (Sheet1), it still takes about 85 seconds to run. If I open a new Worksheet in original Workbook and copy/paste values, run code separately, it still takes about 85 seconds to run. If I open a new Workbook and copy/paste values from Sheet1, it takes 0,49 seconds!

What can I do to have it run in 0,49 seconds in the original Workbook?

CodePudding user response：

I would sort on col A and the delete all the rows at once.
Otherwise, if you need to keep the current logic I would turn calculation to Manual during that part Application.Calculation = xlManual (since you mentioned that it takes only 1/2 sec when you copy/paste values in a blank workbook).
And I would rewrite

cell.Cells(1).Offset(0, 0).Resize(cell.Rows.count, 24).Delete xlUp

cell.Resize(1, 24).Delete xlUp

or perhaps

cell.EntireRow.delete

CodePudding user response：

BigBen, I tried with Intersect but still run time > 80 sec. At the end, my (ugly) solution using Workbooks.Add. Run time = 1,6 sec.

Private Function CombineRanges(ByVal source As Range, ByVal toCombine As Range) As Range
    If source Is Nothing Then
        Set CombineRanges = toCombine
    Else
        Set CombineRanges = union(source, toCombine)
    End If
End Function
'Now, change your loop so that instead of deleting rows, it determines what rows need to be removed:

Sub TestRemoveEmptyRows()
'From https://stackoverflow.com/questions/47872426/for-each-loop-wont-delete-all-rows-with-specific-values/47873216#47873216

Dim wb1     As Workbook
Dim ws1     As Worksheet
Dim rng8    As Range
Dim lr1     As Long

Application.ScreenUpdating = False

Set wb1 = ActiveWorkbook
Set ws1 = wb1.ActiveSheet
lr1 = ws1.Cells(Cells.Rows.count, "A").End(xlUp).Row
Set rng8 = ws1.Range("A1:A" & lr1)
'------------------------------
'Start Timer
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'------------------------------
Dim toDelete As Range
Dim cell As Range

For Each cell In rng8
    If cell.Value = "" Then Set toDelete = CombineRanges(toDelete, cell)
Next
'To here, run time is 0,07 sec.

'If Not toDelete Is Nothing Then toDelete.EntireRow.Delete                          'Works but 81 seconds (For comparison, can't use)
If Not toDelete Is Nothing Then Intersect(toDelete.EntireRow, Range("A:X")).Delete  'Works but 82 seconds
'------------------------------
'Stop Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
'------------------------------
Application.ScreenUpdating = True
End Sub

Below my (ugly) solution using Workbooks.Add. Run time = 1,6 sec.

Sub testremoveBlankRows()
'By adding a new Workbook, run time is 1,6 seconds.

Dim wb1     As Workbook
Dim ws1     As Worksheet
Dim rng8    As Range
Dim cell    As Range
Dim lr1     As Long
Dim rng1    As Range, rng2 As Range

Set wb1 = ActiveWorkbook
Set ws1 = wb1.ActiveSheet
lr1 = ws1.Cells(Cells.Rows.count, "A").End(xlUp).Row
Set rng1 = ws1.Range("A1:X" & lr1)
'------------------------------
'Start Timer
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'-------------------------------------------------
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .EnableEvents = False
    .CutCopyMode = False
End With
'--------------------------------------------------
Dim NWB     As String
Dim lr2     As Long

With Application
    .SheetsInNewWorkbook = 1
    .Workbooks.Add                              'This makes new workbook the active workbook
    NWB = ActiveWorkbook.Name
    rng1.Copy                                   'This doesn't activate wb1
    ActiveSheet.Range("A1").PasteSpecial
    '--------------------------------------------------
    ActiveSheet.UsedRange
    On Error Resume Next
    Set rng8 = Columns("A").SpecialCells(xlBlanks)
    On Error GoTo 0
    
        If rng8 Is Nothing Then Exit Sub
            For Each cell In rng8.Areas
                    cell.Cells(1).Offset(0, 0).Resize(cell.Rows.count, 24).Delete xlUp
            Next cell
    
    lr2 = ActiveSheet.Cells(Cells.Rows.count, "A").End(xlUp).Row
    Set rng2 = ActiveSheet.Range("A1:X" & lr2)
    ws1.Activate
    rng1.ClearContents                          'Important! After removing empty rows, rng2 have less rows.
    rng2.Copy                                   'This doesn't activate NWB
    ActiveSheet.Range("A1").PasteSpecial xlPasteValues
    
    Workbooks(NWB).Close savechanges:=False
End With
'-------------------------------------------------------------
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .EnableEvents = True
    .CutCopyMode = False
End With
'-------------------------------------------------------------
'Stop Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
'-------------------------------------
End Sub

Any suggestions? Thanks in advance,