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

Question

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

我只需要删除从第 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

Answer 1

我已经发布了this solution，但它是在Range(address) 抛出错误的情况下address 超过了一些长度。

但现在的主题严格来说是删除许多行的最快方法，我假设它需要坚持实际 delete 行（即保持格式、公式、公式引用...... )

所以我将再次在此处发布该解决方案（在“按地址删除”方法的标题下）以及第二个（“按排序删除”方法），它要快得多（第一个需要大约 20 秒，第二个处理大约 40k 行需要 0.2 秒，即删除 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

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