Question

下面的代码将1500行与约14列进行比较。执行它们大约需要30分钟。有什么办法，我可以通过更改下面的代码来减少代码。我希望得到您所有的专家意见。该代码具有以下功能
浏览旧表中的所有记录。
如果在NEW表中找到，则什么都不做
如果在新工作表中找不到，请从旧工作表中删除

Option Explicit

Function UpdateOLD() As Long
'     This Sub will do the Following Update
'     Run through all records in OLD
'        if found in NEW  ---> Do nothing
'        if not found in NEW ----> Delete it from OLD.
'
Dim WSO As Worksheet
Dim WSN As Worksheet
Dim MaxRowO As Long, MaxRowN As Long, I As Long, J As Long, lDel As Long
Dim sJob As String, sOps As String, sFirstAddress As String
Dim cCell As Range
Dim bNotFound As Boolean


'---> Disable Events
With Application
    .EnableEvents = False
    .DisplayAlerts = False
    .ScreenUpdating = False
End With

'---> Set Variables
Set WSO = Sheets("Steps")
Set WSN = Sheets("Interface")
MaxRowO = WSO.Range("A" & WSO.Rows.Count).End(xlUp).Row
MaxRowN = WSN.Range("C" & WSN.Rows.Count).End(xlUp).Row
WSO.Range("N2:N" & MaxRowO).ClearContents

'---> Loop thruough all rows in sheet New
For I = MaxRowO To 2 Step -1
    bNotFound = False
    sJob = WSO.Cells(I, "B")
    sOps = WSO.Cells(I, "C")
    Set cCell = WSN.Range("D6:D" & MaxRowN).Find(what:=sJob, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
    If Not cCell Is Nothing Then
        bNotFound = True
        sFirstAddress = cCell.Address
        Do
            '---> Check to See if Ops if found for that Job
            If WSN.Cells(cCell.Row, "E") = sOps Then
                bNotFound = False
                Exit Do
            End If
            Set cCell = WSN.Range("D6:D" & MaxRowN).FindNext(cCell)
        Loop While Not cCell Is Nothing And cCell.Address <> sFirstAddress
    Else
        bNotFound = True
    End If

    '---> Del Record from OLD if Not Found
    If bNotFound Then
        WSO.Range(I & ":" & I).EntireRow.Delete
        'WSO.Range("N" & I) = sJob & " " & sOps & " Deleted as NOT found in NEW"
        lDel = lDel + 1
    End If


Next I

'---> Enable Events
With Application
    .EnableEvents = True
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

UpdateOLD = lDel

End Function

Answer 1

欢迎来到SO。您的代码在大约2000行中进行了尝试，不匹配率约为10％，仅需几秒钟。可能是文件还有其他问题。但是，加快速度的一种方法（大约是我的试验时间的1/2）是将所有bNotFound单元格添加到一个范围的并集内，并在完成后一枪中删除该范围的EntireRow循环。

代码更改：

Dim Rng As Range    'Add in  Declare section 
'
'
'
'
For I = 2 To MaxRowO   'No need to loop backward
'
'
'
'
    If bNotFound Then                       ' Only add to Union of ranges
        If Rng Is Nothing Then
        Set Rng = WSO.Range("A" & I)
        Else
        Set Rng = Union(Rng, WSO.Range("A" & I))
        lDel = lDel + 1
        End If
    End If
Next I

If Not Rng Is Nothing Then Rng.EntireRow.Delete       ' delete in one shot

需要帮助以减少以下代码的执行时间

1 个答案: