更快地一次删除行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

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

Answer 2

我已经发布了this solution，但是当Range(address)超过一定长度时，它出现address投掷错误。

但现在主题严格来说是删除多行的最快方法，我认为必须坚持实际删除行（即保留格式，公式） ，公式参考......）

所以我再次在这里发布该解决方案（在＆＃34;标题符号删除＆＃34;方法的标题下）和第二个（＆＃34;按排序删除＆＃34;方法）速度要快得多（第一个需要20秒，第二个需要0.2秒来处理大约40k行，即删除20k行）

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

＆＃34;按地址删除＆＃34;方法

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

＆＃34;删除bySort＆＃34;方法

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