使用 VBA 删除行的最有效方法

Most efficient way to delete row with VBA

提问by Harry12345

I currently have a macro that I use to delete a record if the ID doesn't exist in a list of ID's I created from an XML document. It does work like I want it to, however I have over 1000 columns in the spreadsheet (one for each day of the year until end of 2015) so it takes ages to delete the row and it can only do 1 or 2 before it says "Excel ran out of resources and had to stop". Below is the code I'm using for the macro, is there another way I can do this so that Excel doesn't run of of resources?

我目前有一个宏，用于在从 XML 文档创建的 ID 列表中不存在该 ID 时删除记录。它确实像我想要的那样工作，但是我在电子表格中有超过 1000 列（一年中的每一天，直到 2015 年底），因此删除该行需要很长时间，并且在它说之前它只能做 1 或 2 “Excel 资源不足，不得不停止”。下面是我用于宏的代码，是否有另一种方法可以做到这一点，以便 Excel 不运行资源？

Sub deleteTasks()

Application.ScreenUpdating = False

Dim search As String
Dim sheet As Worksheet
Dim cell As Range, col As Range
Set sheet = Worksheets("misc")
Set col = sheet.Columns(4)

ActiveWorkbook.Sheets("Schedule").Activate
ActiveSheet.Range("A4").Select
ActiveSheet.Unprotect
ActiveSheet.Range("A:C").EntireColumn.Hidden = False

Do While ActiveCell.Value <> ""

    search = ActiveCell.Value

    Set cell = col.Find(What:=search, LookIn:=xlValues, _
                 LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                 MatchCase:=False, SearchFormat:=False)

    If cell Is Nothing Then 'If the taskID is not in the XML list

    Debug.Print "Deleted Task: " & ActiveCell.Value
    Selection.EntireRow.Delete

    End If

    ActiveCell.Offset(1, 0).Select 'Select next task ID

Loop

ActiveSheet.Range("A:B").EntireColumn.Hidden = True
ActiveSheet.Protect
End Sub

After trying lots of different options, including all the answers listed below. I have realized that whatever the method is, deleting a row with ~1100 columns is going to take a while on my average laptop (2.20 Ghz, 4GB RAM). Since the majority of the rows are empty I have found alternative method which is a lot faster. I just clear the cells which contain data (A:S) and then resize the table to remove the row where I just deleted the data from. This end result is exactly the same as entireColumn.Delete. Below is the code I'm using now

在尝试了许多不同的选项后，包括下面列出的所有答案。我已经意识到，无论使用什么方法，在我的普通笔记本电脑（2.20 Ghz，4GB RAM）上删除大约 1100 列的行都需要一段时间。由于大多数行都是空的，我找到了更快的替代方法。我只是清除包含数据 (A:S) 的单元格，然后调整表格大小以删除我刚刚从中删除数据的行。这个最终结果与entireColumn.Delete. 下面是我现在使用的代码

'New method - takes about 10 seconds on my laptop
Set ws = Worksheets("Schedule")
Set table = ws.ListObjects(1)
Set r = ws.Range("A280:S280")

r.Clear

table.Resize Range("A3:VZ279")

Using anything involving EntireColumn.Deleteor just manually selecting the row and deleting it takes about 20-30 seconds on my laptop. Of course this method only works if your data is in a table.

EntireColumn.Delete在我的笔记本电脑上使用任何涉及或只是手动选择行并删除它需要大约 20-30 秒。当然，此方法仅适用于您的数据在表格中的情况。

回答by hnk

The short answer:

简短的回答：

Use something like

使用类似的东西

ActiveSheet.Range(DelStr).Delete
' where DelStr = "15:15" if you want to delete row 15
'              = "15:15,20:20,32:32" if you want to delete rows 15,20 and 32

The long answer:

长答案：

Important: If you have ~ 30 / 35 rows to delete, the following code works very efficiently. Beyond which it would throw up an error. For code to handle arbitrary number of rows efficiently see the very long answerbelow this.

重要提示：如果您有 ~ 30 / 35 行要删除，则以下代码非常有效。超过它会抛出一个错误。对于有效处理任意行数的代码，请参阅下面的很长的答案。

If you have a function which lets you list out which rows you want to delete, try the code below. This is what I use to very efficiently delete multiple rows with minimum overhead. (the example assumes that you've obtained the rows you need to delete through some program, here I manually feed them in):

如果您有一个函数可以让您列出要删除的行，请尝试以下代码。这是我用来非常有效地以最小开销删除多行的方法。（该示例假设您已经通过某个程序获得了需要删除的行，这里我手动输入它们）：

Sub DeleteRows()
    Dim DelRows() As Variant
    ReDim DelRows(1 To 3)

    DelRows(1) = 15
    DelRows(2) = 18
    DelRows(3) = 21

    '--- How to delete them all together?

    Dim i As Long
    For i = LBound(DelRows) To UBound(DelRows)
        DelRows(i) = DelRows(i) & ":" & DelRows(i)
    Next i

    Dim DelStr As String
    DelStr = Join(DelRows, ",")

    ' DelStr = "15:15,18:18,21:21"
    '           
    '    IMPORTANT: Range strings have a 255 character limit
    '    See the other code to handle very long strings

    ActiveSheet.Range(DelStr).Delete
End Sub

The (very long) efficient solution for arbitrary number of rows and benchmark results:

任意行数和基准测试结果的（非常长的）有效解决方案：

Here are the benchmark results obtained by deleting rows (Time in seconds vs. no. of rows).

以下是通过删除行获得的基准测试结果（以秒为单位的时间与行数）。

The rows are on a clean sheet and contain a volatile formula in the D column from D1:D100000

这些行在一张干净的工作表上，在 D1:D100000 的 D 列中包含一个易失性公式

i.e. for 100,000 rows, they have a formula =SIN(RAND())

即对于 100,000 行，他们有一个公式 =SIN(RAND())

The code is long and not too pretty, but it splits the DelStrinto 250 character substrings and forms a range using these. Then the new DeleteRngrange is deleted in a single operation.

代码很长而且不太漂亮，但是它将DelStr250 个字符的子字符串拆分并使用这些字符形成一个范围。然后DeleteRng在单个操作中删除新范围。

The time to delete may depend on the contents of the cells. The testing/benchmarking, in congruence with a bit of intuition suggests the following results.

删除的时间可能取决于单元格的内容。与一些直觉一致的测试/基准测试表明以下结果。

• Sparse rows/empty cells delete fastest
• Cells with values take somewhat longer
• Cells with formulas take even longer
• Cells which feed into formulas in other cells take longest as their deletion triggers the #Refreference error.

• 稀疏行/空单元格删除速度最快
• 带有值的单元格需要更长的时间
• 带有公式的单元格需要更长的时间
• 输入其他单元格中的公式的单元格需要最长的时间，因为它们的删除会触发#Ref引用错误。

Code:

代码：

Sub DeleteRows()

    ' Usual optimization
    ' Events not disabled as sometimes you'll need to interrupt
    ' You can optionally keep them disabled

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    ' Declarations...

    Dim DelRows() As Variant

    Dim DelStr As String, LenStr As Long
    Dim CutHere_Str As String
    Dim i As Long

    Dim MaxRowsTest As Long
    MaxRowsTest = 1000

    ' Here I'm taking all even rows from 1 to MaxRowsTest
    ' as rows to be deleted

    ReDim DelRows(1 To MaxRowsTest)

    For i = 1 To MaxRowsTest
        DelRows(i) = i * 2
    Next i

    '--- How to delete them all together?

    LenStr = 0
    DelStr = ""

    For i = LBound(DelRows) To UBound(DelRows)
        LenStr = LenStr + Len(DelRows(i)) * 2 + 2

        ' One for a comma, one for the colon and the rest for the row number
        ' The goal is to create a string like
        ' DelStr = "15:15,18:18,21:21"

        If LenStr > 200 Then
            LenStr = 0
            CutHere_Str = "!"       ' Demarcator for long strings
        Else
            CutHere_Str = ""
        End If

        DelRows(i) = DelRows(i) & ":" & DelRows(i) & CutHere_Str
    Next i

    DelStr = Join(DelRows, ",")

    Dim DelStr_Cut() As String
    DelStr_Cut = Split(DelStr, "!,")
    ' Each DelStr_Cut(#) string has a usable string

    Dim DeleteRng As Range
    Set DeleteRng = ActiveSheet.Range(DelStr_Cut(0))

    For i = LBound(DelStr_Cut) + 1 To UBound(DelStr_Cut)
        Set DeleteRng = Union(DeleteRng, ActiveSheet.Range(DelStr_Cut(i)))
    Next i

    DeleteRng.Delete

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

The code to generate the formulas in a blank sheet is

在空白工作表中生成公式的代码是

Sub FillRandom()
    ActiveSheet.Range("D1").FormulaR1C1 = "=SIN(RAND())"
    Range("D1").AutoFill Destination:=Range("D1:D100000"), Type:=xlFillDefault
End Sub

And the code to generate the benchmark results above is

上面生成基准结果的代码是

Sub TestTimeForDeletion()

        Call FillRandom

        Dim Time1 As Single, Time2 As Single
        Time1 = Timer

        Call DeleteRows

        Time2 = Timer
        MsgBox (Time2 - Time1)
End Sub

Note:Many thanks to brettdjfor pointing out the error which gets thrown when the length of DelStrexceeding 255 characters. It seems to be a knownproblem and as I painfully found out, it still exists for Excel 2013.

注意：非常感谢brettdj指出长度DelStr超过 255 个字符时抛出的错误。这似乎是一个已知问题，正如我痛苦地发现的那样，它仍然存在于 Excel 2013 中。

回答by BeachBum68

This code uses AutoFilter and is significantly faster than looping through rows.

此代码使用 AutoFilter 并且比循环遍历行快得多。

我每天都使用它，应该很容易弄清楚。

只需将您要查找的内容和要搜索的列传递给它即可。

如果需要，您也可以对列进行硬编码。

private sub PurgeRandy
    Call FindDelete("F", "Randy")
end sub

Public Sub FindDelete(sCOL As String, vSearch As Variant) 'Simple find and Delete
Dim lLastRow As Integer
Dim rng As Range
Dim rngDelete As Range
    Range(sCOL & 1).Select
    [2:2].Insert
    [2:2] = "***"
    Range(sCOL & ":" & sCOL).Select

    With ActiveSheet
        .UsedRange
            lLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
        Set rng = Range(sCOL & 2, Cells(lLastRow, sCOL))
            rng.AutoFilter Field:=1, Criteria1:=vSearch
        Set rngDelete = rng.SpecialCells(xlCellTypeVisible)
            rng.AutoFilter
            rngDelete.EntireRow.Delete
        .UsedRange
    End With
End Sub

回答by brettdj

In this case a simple working formula can be used to see if each of the values in your range to be tested (column A of schedule) exist in column F of misc

在这种情况下，可以使用一个简单的工作公式来查看要测试的范围内的每个值（schedule 的A 列）是否存在于misc 的F 列中

In B4it would =MATCH(A4,misc!D:D,0)

在B4它会=MATCH(A4,misc!D:D,0)

This can be used manually or with code for an efficient delete as the formula by design returns an error if there is no match which we can efficiently delete with VBAwith either:

这可以手动使用或与代码一起使用以进行有效删除，因为如果没有匹配项，我们可以VBA使用以下任一方法有效删除，则设计公式会返回错误：

• AutoFilter
• SpecialCells(the designpiece*)

• AutoFilter
• SpecialCells（设计作品*）

In xl2007 note that there is a limit of 8192 discrete areasthat can be selected with SpecialCells

在 xl2007 中注意有8192 个离散区域的限制，可以选择SpecialCells

code

代码

Sub ReCut()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range

Set ws1 = Sheets("misc")
Set ws2 = Sheets("schedule")

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With

Set rng1 = ws2.Range(ws2.[a4], ws2.Cells(Rows.Count, "A").End(xlUp))
ws2.Columns(2).Insert
With rng1.Offset(0, 1)
     .FormulaR1C1 = "=MATCH(RC[-1],'" & ws1.Name & "'!C[2],0)"
     On Error Resume Next
    .Cells.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
     On Error GoTo 0
End With

ws2.Columns(2).Delete

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub

回答by Bakul Krishana

Note: I don't have enough "reputation" to add my comments thus posting as answer. Credit to hnkfor wonderful answer (Long Answer). I have one edit as suggestion:

注意：我没有足够的“声誉”来添加我的评论，因此发布为答案。感谢HNK为精彩的回答（长的答案）。我有一个编辑作为建议：

Once you split the long string and in case the last block is more than the set character then it is having "!" at the end which is throwing error for range method. Addition of IF statement and MID is ensuring that there is no such character.

拆分长字符串后，如果最后一个块多于设置的字符，则它具有“！” 最后是范围方法抛出错误。IF 语句和 MID 的添加确保没有这样的字符。

To handle that, use:

要处理它，请使用：

For i = LBound(DelStr_Cut) + 1 To UBound(DelStr_Cut)
    If Right(DelStr_Cut(i), 1) = "!" Then
        DelStr_Cut(i) = Mid(DelStr_Cut(i), 1, Len(DelStr_Cut(i)) - 1)
        Set DeleteRng = Union(DeleteRng, ActiveSheet.Range(DelStr_Cut(i)))
    Else
        Set DeleteRng = Union(DeleteRng, ActiveSheet.Range(DelStr_Cut(i)))
    End If
Next i

Thanks, Bakul

谢谢，巴库尔