删除行VBAmacros需要大量的时间

我有一个macros根据列中的某个值删除行，然后对它们进行sorting。 它工作正常。 但是，工作表从大约4000行开始，并且macros最终删除了大约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

我更喜欢build立一个被删除的行的string，然后做一个删除。 这里是昨天在这里举行的另一个post的样本：

 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 

当您只执行一次删除操作时，也不用担心closures计算或屏幕更新等