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