Question

我目前有一个用于删除记录的宏，如果在我从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

尝试了很多不同的选项，包括下面列出的所有答案。我已经意识到，无论方法是什么，删除一行~1100列将占用一般笔记本电脑（2.20 Ghz，4GB RAM）。由于大多数行都是空的，我找到了更快的替代方法。我只是清除包含数据（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")

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

Answer 1

答案简短：

使用类似

的内容

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

答案很长：

重要提示：如果您要删除~30 / 35行，则以下代码可以非常有效地运行。除此之外，它会引发错误。对于有效处理任意行数的代码，请参阅下面的非常长的答案。

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

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

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

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

行位于干净的工作表上，并且在D1列的D列中包含易失性公式：D100000

即。对于100,000行，它们具有公式=SIN(RAND())

enter image description here

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

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

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

代码：

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

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

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

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

Sub TestTimeForDeletion()

        Call FillRandom

        Dim Time1 As Single, Time2 As Single
        Time1 = Timer

        Call DeleteRows

        Time2 = Timer
        MsgBox (Time2 - Time1)
End Sub

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

Answer 2

这段代码使用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

Answer 3

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

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

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

AutoFilter
SpecialCells（ design piece *）

在xl2007中请注意，可以使用SpecialCells

选择8192 discrete areas的限制

码

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

Answer 4

注意：我没有足够的＆＃34;声誉＆＃34;添加我的评论，从而发布作为答案。感谢hnk获得精彩答案（长答案）。我有一个编辑作为建议：

分割长字符串后，如果最后一个字符串超过设定字符，那么它就是＆＃34;！＆＃34;最后是范围方法抛出错误。添加IF语句和MID可确保不存在此类字符。

要处理此问题，请使用：

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

谢谢， BaKul酒店

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

4 个答案: