刪除行VBA宏需要大量時間

Question

我有一個宏，該宏根據列中的某個值刪除行，然后對其進行排序。 工作正常。 但是，工作表從大約4000行開始，宏最終刪除了大約2000行，並且需要1分25秒來完成。 我想知道是否有什么我可以做的，這將減少花費的時間。 這是代碼：

'remove numbers that are not allowed based on values in "LimitedElements" worksheet

For i = imax To 1 Step -1
    a = Sheets("FatigueResults").Cells(i, 1).Value
    Set b = Sheets("LimitedElements").Range("A:A")
    Set c = b.Find(What:=a, LookIn:=xlValues)

    If Not c Is Nothing Then
        Sheets("FatigueResults").Rows(i).EntireRow.Delete
    End If
Next i

'delete unecessary or redundant rows and columns
Rows(3).EntireRow.Delete
Rows(1).EntireRow.Delete
Columns(23).EntireColumn.Delete
Columns(22).EntireColumn.Delete
Columns(21).EntireColumn.Delete
Columns(20).EntireColumn.Delete
Columns(14).EntireColumn.Delete
Columns(13).EntireColumn.Delete
Columns(12).EntireColumn.Delete
Columns(11).EntireColumn.Delete
Columns(4).EntireColumn.Delete
Columns(3).EntireColumn.Delete
Columns(2).EntireColumn.Delete

'sort data
    Dim strDataRange As Range
    Dim keyRange As Range

    Set strDataRange = Range("A:Q")
    Set keyRange1 = Range("B1")
    Set keyRange2 = Range("G1")
    strDataRange.sort Key1:=keyRange1, Order1:=xlDescending,     Key2:=keyRange2, Order2:=xlDescending, Header:=xlYes

'delete rows that are not in the included values    For i = imax To 2 Step -1

    If (Cells(i, 2).Value <> 0.04 And Cells(i, 2).Value <> 0.045 And Cells(i, 2).Value <> 0.05 And Cells(i, 2).Value <> 0.056 And Cells(i, 2).Value <> 0.063 And Cells(i, 2).Value <> 0.071 And Cells(i, 2).Value <> 0.08 And Cells(i, 2).Value <> 0.09 Or Cells(i, 3).Value <= 0) Then

        ActiveSheet.Rows(i).EntireRow.Delete

    End If

Next i

Answer 1

在開始時添加：

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

最后添加：

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

另外，代替

If (Cells(i, 2).Value <> 0.04 And Cells(i, 2).Value <> 0.045 And Cells(i, 2).Value <> 0.05 And Cells(i, 2).Value <> 0.056 And Cells(i, 2).Value <> 0.063 And Cells(i, 2).Value <> 0.071 And Cells(i, 2).Value <> 0.08 And Cells(i, 2).Value <> 0.09 Or Cells(i, 3).Value <= 0) Then

    ActiveSheet.Rows(i).EntireRow.Delete

End If

采用

Select Case Cells(i, 2)
Case 0.4, 0.045, 0.05, 0.056, 0.063, 0.071, 0.08, 0.09, Is < 0
    'Do nothing
Case Else
    ActiveSheet.Rows(i).EntireRow.Delete
End Select

Answer 2

我更喜歡構建要刪除的一串行，然后執行一次刪除。 這是我昨天在此處整理的另一篇文章的樣本：

Sub DeleteRows()
Dim i As Long, DelRange As String
For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row 'Doesn't matter which way you go when you delete in one go
    If Left(Cells(i, 6), 3) = "314" Then DelRange = DelRange & "," & i & ":" & i 'Change the "314" as you see fit
Next i
Range(Right(DelRange, Len(DelRange) - 1)).Delete
End Sub

當您只執行一次刪除操作時，也不必擔心關閉計算或屏幕更新等操作