加快包含计算的循环

更改后的代码（整个模块在这里）

Sub Filter_TPDrop() ' ' Filter based on Voids and < 5 min times ' Dim LstRow, i, TestVoid, TestTime As Long Dim ActiveDate As Variant Dim NewData, delRange As Range Dim T1, T2 As Date With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With ActiveDate = Worksheets("TPDrop").Range("H2").Value ' ' Sort the Table by location and cheque open time Worksheets("TPDrop").Range("A1").Sort _ Key1:=Worksheets("TPDrop").Columns("A"), Header:=xlYes, _ Key2:=Worksheets("TPDRop").Columns("I"), Header:=xlYes Worksheets("TPDrop").Range("A1").Select ' Find last row of Data With ActiveSheet.UsedRange LstRow = .Rows(.Rows.Count).Row End With ' Delete Any Row where K,L and M = 0 (Void) and where chqtime , 5 min For i = 2 To LstRow TestVoid = (Range("K" & i).Value + Range("L" & i).Value + Range("M" & i).Value) T1 = (Range("I" & i).Value) T2 = (Range("J" & i).Value) TestTime = DateDiff("n", T1, T2) If TestVoid = 0 Or TestTime < 5 Then Set delRange = Rows(i) Else Set delRange = Union(delRange, Rows(i)) End If Next i If Not delRange Is Nothing Then delRange.Delete shift:=xlUp ' reset LstRow after filtering and put line between locations With ActiveSheet.UsedRange LstRow = .Rows(.Rows.Count).Row End With Set NewData = ActiveSheet.UsedRange For i = LstRow To 3 Step -1 If NewData.Cells(i, 1).Value <> NewData.Cells(i - 1, 1).Value Then NewData.Cells(i, 1).EntireRow.Insert End If Next i 

“

 With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub 

这段代码的作品，但需要大约4分钟运行6400行。 我不熟悉数组，但通过阅读其他职位，使用它们可以大大加快这部分代码的理解。 任何人有任何build议？

 Sub Filter_TPDrop() ' ' Filter based on Voids and < 5 min times ' Dim LstRow, i, TestVoid, TestTime As Long Dim ActiveDate As Variant Dim NewData As Range Dim T1, T2 As Date With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With ActiveDate = Worksheets("TPDrop").Range("H2").Value ' ' Sort the Table by location and cheque open time Worksheets("TPDrop").Range("A1").Sort _ Key1:=Worksheets("TPDrop").Columns("A"), Header:=xlYes, _ Key2:=Worksheets("TPDRop").Columns("I"), Header:=xlYes Worksheets("TPDrop").Range("A1").Select ' Find last row of Data With ActiveSheet.UsedRange LstRow = .Rows(.Rows.Count).Row End With ' Delete Any Row where K,L and M = 0 (Void) and where chqtime < 5 min For i = LstRow To 2 Step -1 TestVoid = (Range("K" & i).Value + Range("L" & i).Value _ + Range("M" & i).Value) T1 = (Range("I" & i).Value) T2 = (Range("J" & i).Value) TestTime = DateDiff("n", T1, T2) If TestVoid = 0 _ Or TestTime < 5 _ Then Rows(i).Delete Next i End Sub 

Answer 1

您正在循环删除。 看到我的答案 ，最后删除，而不是在循环;）这将大大提高你的速度。

更改For i = LstRow To 2 Step -1到For i = 2 To LstRow

并更换

 If TestVoid = 0 _ Or TestTime < 5 _ Then Rows(i).Delete 

通过

 If TestVoid = 0 Or TestTime < 5 Then If delRange Is Nothing Then Set delRange = .Rows(i) Else Set delRange = Union(delRange, .Rows(i)) End If End If 

Next i把这一行

 If Not delRange Is Nothing Then delRange.Delete shift:=xlUp