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

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