Question

在此网站上基于on another question我开始想知道删除具有特定条件的所有行的最快方法。

上面提到的问题有各种解决方案：

（1）遍历工作表上的所有行（向后）并逐个删除符合条件的所有行。

（2）首先将适用范围移动到数组中，然后评估数组中的条件，并根据该条件在基础工作表上逐个删除所有行。

可能的改进可能是删除块中的所有行以减少访问工作表的开销。但是如果你走这条路线，那么在实际删除范围之前，你有各种选项来“存储”范围：

（1）使用Intersect合并应删除的范围。

（2）只需编写一个String，其中包含要删除的所有行。

那么，这是最快的方法吗？

Answer 1

一个有效的解决方案是标记所有行以保留并通过对标记进行排序将所有行移动到最后删除。这样，复杂性不会随着要删除的行数而增加。

此示例在不到一秒的时间内删除50000行，列I等于2的所有行：

Sub DeleteMatchingRows()
    Dim rgTable As Range, rgTags As Range, data(), tags(), count&, r&

    ' load the data in an array
    Set rgTable = ActiveSheet.UsedRange
    data = rgTable.Value

    ' tag all the rows to keep with the row number. Leave empty otherwise.
    ReDim tags(1 To UBound(data), 1 To 1)
    tags(1, 1) = 1  ' keep the header
    For r = 2 To UBound(data)
      If data(r, 9) <> 2 Then tags(r, 1) = r  ' if column I <> 2 keep the row
    Next

    ' insert the tags in the last column on the right
    Set rgTags = rgTable.Columns(rgTable.Columns.count + 1)
    rgTags.Value = tags

    ' sort the rows on the tags which will move the rows to delete at the end
    Union(rgTable, rgTags).Sort key1:=rgTags, Orientation:=xlTopToBottom, Header:=xlYes
    count = rgTags.End(xlDown).Row

    ' delete the tags on the right and the rows that weren't tagged
    rgTags.EntireColumn.Delete
    rgTable.Resize(UBound(data) - count + 1).Offset(count).EntireRow.Delete
End Sub

请注意，它不会改变行的顺序。

Answer 2

以下是我可以想到的完成任务的“平均时间”的所有可能选项：

Option Base 1
Option Explicit

Sub FixWithArraysAndDeleteRange()

Dim lngItem As Long
Dim varArray() As Variant
Dim wksItem As Worksheet
Dim rngRangeToDelete As Range

Dim dttStart As Date

Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)"
Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2

dttStart = Now()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set wksItem = Worksheets(1)
varArray() = wksItem.Range("I25:I50000").Value2

For lngItem = LBound(varArray) To UBound(varArray)
    If IsNumeric(varArray(lngItem, 1)) Then
        If Int(varArray(lngItem, 1)) = 2 Then
            If rngRangeToDelete Is Nothing Then
              Set rngRangeToDelete = wksItem.Rows(lngItem + 24)
            Else
              Set rngRangeToDelete = Intersect(rngRangeToDelete, wksItem.Rows(lngItem + 24))
            End If
        End If
    End If
Next lngItem

rngRangeToDelete.EntireRow.Delete

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Debug.Print Format(Now() - dttStart, "HH:MM:SS")
'Average time around 0 seconds

End Sub

Sub FixWithLoop()

Dim lngRow As Long
Dim lngLastRow As Long
Dim wksItem As Worksheet

Dim dttStart As Date

Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)"
Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2

dttStart = Now()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set wksItem = Worksheets(1)
lngLastRow = wksItem.Cells(wksItem.Rows.Count, "I").End(xlUp).Row

For lngRow = lngLastRow To 25 Step -1
    If Int(wksItem.Cells(lngRow, "I").Value) = 2 Then wksItem.Rows(lngRow).Delete
Next lngRow

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Debug.Print Format(Now() - dttStart, "HH:MM:SS")
'Average time ~3 seconds

End Sub

Sub FixWithLoopInChunks()

Dim lngRow As Long
Dim lngLastRow As Long
Dim wksItem As Worksheet
Dim strRowsToDelete As String
Dim intDeleteCount As Integer

Dim dttStart As Date

Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)"
Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2

dttStart = Now()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set wksItem = Worksheets(1)
lngLastRow = wksItem.Cells(wksItem.Rows.Count, "I").End(xlUp).Row

For lngRow = lngLastRow To 25 Step -1
    If Int(wksItem.Cells(lngRow, "I").Value) = 2 Then
        intDeleteCount = intDeleteCount + 1
        strRowsToDelete = strRowsToDelete & ",I" & lngRow
    End If
    If intDeleteCount >= 30 Then
        strRowsToDelete = Mid(strRowsToDelete, 2)
        wksItem.Range(strRowsToDelete).EntireRow.Delete
        intDeleteCount = 0
        strRowsToDelete = ""
    End If
Next lngRow

If intDeleteCount > 0 Then
    strRowsToDelete = Mid(strRowsToDelete, 2)
    wksItem.Range(strRowsToDelete).EntireRow.Delete
End If

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Debug.Print Format(Now() - dttStart, "HH:MM:SS")
'Average time ~3 seconds

End Sub

Sub FixWithArraysAndDeleteChunks()

Dim lngItem As Long
Dim varArray() As Variant
Dim wksItem As Worksheet
Dim strRowsToDelete As String
Dim intDeleteCount As Integer

Dim dttStart As Date

Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)"
Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2

dttStart = Now()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set wksItem = Worksheets(1)
varArray() = wksItem.Range("I25:I50000").Value2

For lngItem = UBound(varArray) To LBound(varArray) Step -1
    If IsNumeric(varArray(lngItem, 1)) Then
        If Int(varArray(lngItem, 1)) = 2 Then
            intDeleteCount = intDeleteCount + 1
            strRowsToDelete = strRowsToDelete & ",I" & lngItem + 24
        End If
        If intDeleteCount >= 30 Then
            strRowsToDelete = Mid(strRowsToDelete, 2)
            wksItem.Range(strRowsToDelete).EntireRow.Delete
            intDeleteCount = 0
            strRowsToDelete = ""
        End If
    End If
Next lngItem

If intDeleteCount > 0 Then
    strRowsToDelete = Mid(strRowsToDelete, 2)
    wksItem.Range(strRowsToDelete).EntireRow.Delete
End If

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Debug.Print Format(Now() - dttStart, "HH:MM:SS")
'Average time ~2 seconds

End Sub

根据上述测试，“最快”路线是使用数组，使用Intersect保存要删除的行范围，然后一起删除所有行。

_{注意，如果您使用的是Application.Union而不是Intersect，那么该方法的时间会显着下降，而sub将会运行近30秒。}

然而，时差非常小且可以忽略不计（对于50.000行）。

如果我的速度测试设置有任何可能导致结果偏差的缺陷，或者我错过了您希望看到的其他方法，请告诉我。

更新

这是@SiddharthRout提供的另一种方法。我不想抄袭。然而，我想比较时间结果。因此，这里的子重写与其他人进行比较，并记录在我的系统上。

Sub DeleteFilteredRows_SiddharthRout()

Dim wksItem As Worksheet
Dim rngRowsToDelete As Range

Dim dttStart As Date

Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)"
Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2

dttStart = Now()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set wksItem = Worksheets(1)
wksItem.AutoFilterMode = False
wksItem.Range("I25:I50000").AutoFilter Field:=1, Criteria1:=2
Set rngRowsToDelete = wksItem.Range("I25:I50000").SpecialCells(xlCellTypeVisible)
wksItem.AutoFilterMode = False
wksItem.Rows.Hidden = False

rngRowsToDelete.EntireRow.Delete

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Debug.Print Format(Now() - dttStart, "HH:MM:SS")
'Average time around 5 seconds

End Sub

与其他所有方法相比，这种方法似乎稍微慢了一些。

Answer 3

<强>编辑

经过多次测试后，Sort＆amp; Delete似乎比RemoveDuplicates

快一点

所以我提出了以下解决方案（在答案结束时保留第一个解决方案）

Sub FixWithSort()
Dim testRng As Range
Dim dttStart As Date

Set testRng = Worksheets("Test").Range("I25:I50000")

With testRng
    .Formula = "=RandBetween(1, 5)"
    .Value2 = .Value2
End With

dttStart = Now()

With testRng
    With .Offset(, 1)
        .FormulaR1C1 = "=IF(RC[-1]=2,"""",row())"
        .Value2 = .Value2
    End With

    .Resize(, 2).Sort key1:=.Columns(2), Orientation:=xlTopToBottom, Header:=xlYes
    Range(.Cells(1, 2).End(xlDown).Offset(1, -1), .Cells(1, 1).End(xlDown)).EntireRow.Delete
    .Columns(2).ClearContents
End With

Debug.Print Format(Now() - dttStart, "HH:MM:SS")
dttStartGlobal = dttStartGlobal + Now() - dttStart

End Sub

使用RemoveDuplicates

的上一个（并且速度稍慢）解决方案

Option Explicit

Sub FixWithRemoveDuplicates()
Dim testRng As Range
Dim dttStart As Date

Set testRng = Worksheets("Test").Range("I25:I50000")

With testRng
    .Formula = "=RandBetween(1, 5)"
    .Value2 = .Value2
End With

dttStart = Now()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

With testRng
    With .Offset(, 1)
        .FormulaR1C1 = "=IF(RC[-1]=2,""a"",row())"
        .Value2 = .Value2
    End With
    .EntireRow.RemoveDuplicates Columns:=Array(.Columns(2).Column), Header:=xlNo
    .Offset(, 1).Find(what:="a", LookIn:=xlValues, LookAt:=xlWhole).EntireRow.Delete
    .Columns(2).ClearContents
End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Debug.Print Format(Now() - dttStart, "HH:MM:SS")
'Average time around 0 seconds

End Sub

删除无法使用SpecialCells抓取的行的最快方法

3 个答案:

更新