VBA行操作执行时间太长

Question

所以我在Execl VB中通过以下脚本遍历行并删除那些不包含特定关键字的行。

Sub Main() 
    RowsDeleted = 0 
    Keyword = "COLA" 
    For i = 2 to ActiveSheet.UsedRange.Rows.Count 
     If InStr(Cells(i, 1).Value, Keyword) = 0 Then 
      Rows(i).Delete 
      RowsDeleted = RowsDeleted + 1 
      i = i - 1 
     End If 
    Next i 
    MsgBox("Rows Deleted: " & RowsDeleted) 
End Sub 

问题是这个脚本需要很长时间才能执行（大约8分钟〜73000个条目）。为什么是这样，我将如何去改进它？

Answer 1

修改你的代码看起来像这样：

Sub Main() 
    On Error Goto ErrHandler 
    Application.ScreenUpdating = False 

    RowsDeleted = 0 
    Keyword = "COLA" 
    For i = ActiveSheet.UsedRange.Rows.Count to 2 
     If InStr(Cells(i, 1).Value, Keyword) = 0 Then 
      Rows(i).Delete 
      RowsDeleted = RowsDeleted + 1 
      ' i = i - 1 ' -- manually changing the loop counter is a bad idea 
     End If 
    Next i 
    MsgBox("Rows Deleted: " & RowsDeleted) 

EndSub: 
    Application.ScreenUpdating = True 
    exit sub 
ErrHandler: 
    ' Error handling here 
    resume EndSub 
End Sub 

是必需的错误处理程序，以确保ScreenUpdating被恢复，即使是在一个错误的情况。

Answer 2

对其他答案没有意义，但这只会帮助排除故障。 你需要做的是去除代码行

Rows(i).Delete 

内的（潜在的）长期运行循环是什么原因造成的减速。

你需要将它重新写这样的...

Sub Main() 
    RowsDeleted = 0 
    Keyword = "COLA" 

    Dim rng As Excel.Range 
    Dim arr() As Variant 
    Dim str As String 
    arr = ActiveSheet.UsedRange 
    Dim R As Long 

    For R = 1 To UBound(arr, 1) ' First array dimension is rows. 
     If InStr(arr(R, 1), Keyword) = 0 Then 
      If str <> "" Then 
       str = "," & str 
      End If 
      str = str & arr(R, 1).Address 
     End If 
    Next R 

    Set rng = ActiveSheet.Range(str) 
    RowsDeleted = rng.Rows.Count 
    rng.Delete 

    MsgBox ("Rows Deleted: " & RowsDeleted) 

End Sub 

Answer 3

它需要年龄可能是由于您的单元格的公式是将要被删除。

你应该做的是关闭自动计算并在删除之前清除该行的内容。你也应该从下往上开始！

试试这个：

Sub Main() 
    Dim lMode As Long 

    ' Store initial state of Calculation mode 
    lMode = Application.Calculation 
    ' Change to Manual Calculation 
    Application.Calculation = xlCalculationManual 
    ' Disable screen update 
    Application.ScreenUpdating = False 

    RowsDeleted = 0 
    Keyword = "COLA" 

    ' Start from bottom up! 
    For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1 
     If InStr(Cells(i, 1).Value, Keyword) = 0 Then 
      Rows(i).ClearContents 
      Rows(i).Delete 
      RowsDeleted = RowsDeleted + 1 
     End If 
    Next i 

    ' Restore screenupdate and calculation mode 
    Application.ScreenUpdating = True 
    Application.Calculation = lMode 

    MsgBox ("Rows Deleted: " & RowsDeleted) 
End Sub 

Answer 4

这里可能是一些看， 它过滤柱一种用于细胞<>“可乐”，并清除它们 然后它排序列A因此在A列中空白单元格现在在底部 然后删除空白行。 不知道OP的ws的设置，可能需要进行调整。

在我的示例表上，我使用了81,000行，当我运行代码时大约需要5秒。

Sub SomeDeleteCode() 
    Dim Rws As Long, Rng As Range, nwRw As Long 

    Rws = Cells(Rows.Count, "A").End(xlUp).Row 

    Application.ScreenUpdating = 0 
    Application.Calculation = xlCalculateManual 

    Columns("A:A").AutoFilter Field:=1, Criteria1:="<>*Cola*" 
    Set Rng = Range(Cells(2, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeVisible) 
    Rng.ClearContents 
    ActiveSheet.AutoFilterMode = 0 

    Columns(1).Sort Key1:=Range("A1"), Header:=xlYes 
    nwRw = Cells(Rows.Count, "A").End(xlUp).Row 

    Range(Range("B" & nwRw + 1), Range("B" & nwRw + 1).End(xlDown)).EntireRow.Delete 
    Application.Calculation = xlCalculationAutomatic 
End Sub