一次删除 40k+ 行的更快方法

有没有更快的方法来删除行？

我只需要删除从第 3 行到最后一行有数据的奇数行

下面的代码可以工作，但速度很慢：

Dim toDelete As Range
For icount = endRow To 3 Step -2
    If toDelete Is Nothing Then
        Set toDelete = Rows(icount)
    Else
        Set toDelete = Union(toDelete, Rows(icount))
    End If
Next
toDelete.Delete shift:=xlUp

我已经发帖了这个解决方案 https://stackoverflow.com/questions/39808453/run-time-error-1004-method-range-of-object-global-failed-while-deleting/39809397?noredirect=1#comment66910264_39809397，但这是在一个背景下Range(address)抛出错误时address超过了一定的长度。

但现在的主题严格是删除多行的最快方法，我假设实际上需要坚持delete行（即维护格式、公式、公式引用...）

因此，我将再次在此发布该解决方案（在“按地址删除”方法的标题下）以及第二个解决方案（“按排序删除”方法），该解决方案要快得多（第一个需要大约 20 秒，第二个需要大约 0 ,2秒处理一些40k行，即删除20k行）

两种解决方案在OP之后都稍微专业化For icount = endRow To 3 Step -2的东西，但它可以很容易地变得更通用

“按地址删除”方法

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

“按排序删除”方法

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