Faster way to delete rows 40k+ rows at once

Question

Is there a faster way to delete rows ?

I just need to delete rows with odd row numbers from row 3 to the last row with data in it

Below code works but is ver

Answer 1

I already posted this solution, but it was in the context of a Range(address) throwing errors when address exceeded some length.

But now the topic is strictly that of the fastest way to delete many rows and I'll assume it's required to stick to actually delete rows (i.e. mantaining formatting, formulas, formula references...)

So I'll post here that solution again (under the header of "Delete by Address" approach) along with a 2nd one ("Delete by Sort" approach) which is much much faster (1st takes some 20 secs, 2nd takes some 0,2 secs to process some 40k rows, i.e. delete 20k rows)

Both solutions are slightly specialized after the OP For icount = endRow To 3 Step -2 thing, but it can be easily made more general

---

"Delete by Address" approach

Option Explicit

Sub main()    
    Dim icount As Long, endrow As Long
    Dim strDelete As String

    With Worksheets("Delete")
        For icount = .Cells(.Rows.Count, "C").End(xlUp).Row To 3 Step -2
            strDelete = strDelete & "," & icount & ":" & icount
        Next icount
    End With

    DeleteAddress Right(strDelete, Len(strDelete) - 1)        
End Sub

Sub DeleteAddress(ByVal address As String)
    Dim arr As Variant
    Dim iArr As Long
    Dim partialAddress As String

    arr = Split(address, ",")
    iArr = LBound(arr)
    Do While iArr < UBound(arr)
        partialAddress = ""
        Do While Len(partialAddress & arr(iArr)) + 1 <= 250 And iArr < UBound(arr)
            partialAddress = partialAddress & arr(iArr) & ","
            iArr = iArr + 1
        Loop
        If Len(partialAddress & arr(iArr)) <= 250 Then
            partialAddress = partialAddress & arr(iArr)
            iArr = iArr + 1
        Else
            partialAddress = Left(partialAddress, Len(partialAddress) - 1)
        End If
        Range(partialAddress).Delete shift:=xlUp
    Loop
End Sub

---

"Delete bySort" approach

Option Explicit

Sub main()
    Dim nRows As Long
    Dim iniRng As Range

    With Worksheets("Delete")
        nRows = .Cells(.Rows.Count, "C").End(xlUp).Row
        .Cells(1, .UsedRange.Columns(.UsedRange.Columns.Count + 1).Column).Resize(nRows) = Application.Transpose(GetArray(nRows, 3))
        With .UsedRange
            .Sort key1:=.Columns(.Columns.Count), Header:=xlNo
            Set iniRng = .Columns(.Columns.Count).Find(what:=nRows + 1, LookIn:=xlValues, lookat:=xlWhole)
            .Columns(.Columns.Count).ClearContents
        End With
        .Range(iniRng, iniRng.End(xlDown)).EntireRow.Delete
    End With   
End Sub

Function GetArray(nRows As Long, iniRow As Long)
    Dim i As Long

    ReDim arr(1 To nRows) As Long
    For i = 1 To nRows
        arr(i) = i
    Next i
    For i = nRows To iniRow Step -2
        arr(i) = nRows + 1
    Next i
    GetArray = arr
End Function

Answer 2

Sub Delete()
    Dim start: start = Timer
    Dim Target As Range
    Dim Source(), Data()
    Dim lastRow As Long, x As Long, x1 As Long, y As Long

    With Worksheets("Sheet1")
        lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Set Target = Intersect(.Rows(5 & ":" & lastRow), .UsedRange)
    End With

    Debug.Print "Rows: " & Target.Rows.Count, "Columns: " & Target.Columns.Count
    Source = Target.Value

    ReDim Data(1 To Target.Rows.Count, 1 To Target.Columns.Count)

    For x = 1 To UBound(Source, 1) Step 2
        x1 = x1 + 1
        For y = 1 To UBound(Source, 2)
            Data(x1, y) = Source(x, y)
        Next
    Next

    Target.ClearContents
    Target.Resize(x1).Value = Data

    With Worksheets("Sheet1")
        lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Set Target = Intersect(.Rows(5 & ":" & lastRow), .UsedRange)
    End With

    Debug.Print "Rows: " & Target.Rows.Count, "Columns: " & Target.Columns.Count
    Debug.Print "Time in Second(s): "; Timer - start
End Sub


Sub Test()
    Dim r As Range
    Application.ScreenUpdating = False

    For Each r In [A1:H80000]
       r = r.Address
    Next r

    Application.ScreenUpdating = True
End Sub