Vba 一次删除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

我已经发布了，但它是在Rangeaddress的上下文中，当地址超过某个长度时抛出错误

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

因此，我将在这里再次发布该解决方案，其标题为“按地址删除”方法，以及第二种速度更快的“按排序删除”方法。第一种方法大约需要20秒，第二种方法大约需要0,2秒来处理40k行，即删除20k行

这两种解决方案在icount=endRow的第3步第2步操作之后都稍微专门化了一点，但它可以很容易地变得更通用

按地址删除方法

---

“非常慢”大约需要多长时间？@TimWilliams我尝试了操作代码，令人惊讶的是，在空白工作表上运行几乎要花上一辈子的时间。我设置endRow=80000，但没有包含toDelete.Delete命令lol..你说得对。我有大约15分钟的休息时间来回答。我会努力改进它。哈哈，我回来发布了一个与你的更新非常相似的答案！这比删除行快得多。也许值得添加一些注释，说明它是如何工作的，以及它与删除行有何不同。假定为常量，但可以使用.Formula而不是.value，并且其他地方引用已处理范围的任何公式都不会像使用delete时那样更新。如果将行集合Target=Intersect.Rows5&:&lastRow.UsedRange中的5更改为3，是否应使用行集合Target=Intersect.Rows5&:&lastRow.UsedRange？

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

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