Question

将代码更改为此（整个模块在此处）

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

＆＃39;

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


End Sub

这段代码可以运行，但需要大约4分钟才能运行6400行。我不熟悉数组但是通过阅读其他帖子了解使用它们可以大大加快这部分代码。任何人都有建议？

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

您正在循环中删除。请参阅我的Answer，它最后会删除而不是循环;）这会大大提高你的速度。

将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

加速包含计算的循环

1 个答案: