VBA 优化 3 个循环的性能

Question

首先，我希望检查“Sheet1”的 D 列每一行中的值是否与“已接受”的 A 列的任何行匹配。如果匹配，我想将“Sheet1”那一行的 B 列中的值复制到“已接受”的 D 列中。

但是，由于“Sheet1”的 B 列中有 2 个可能的值，我想将这些值拆分为“已接受”的两列 - D 列和 E 列。因此，下一个循环，如果列中的值“Accepted”的 D 不是“Restricted”，然后将该值复制到 E 列并删除 D 列的内容。

代码运行良好，因为它帮助我实现了我的目标，但是，这个过程花费了太长时间，经过一番调查，我发现延迟只发生在最后一个循环中。我想知道我是否可以加快这个过程，谢谢！

Dim i As Long
Dim j As Long
Dim k As Long

'to speed up the VBA code
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With


AcceptedLastRow = ActiveWorkbook.Worksheets("Accepted").Range("A" & Rows.Count).End(xlUp).Row
Sheet1LastRow = ActiveWorkbook.Worksheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row

    For j = 1 To AcceptedLastRow
        For i = 1 To Sheet1LastRow
            If ActiveWorkbook.Worksheets("Sheet1").Cells(i, 4).Value = ActiveWorkbook.Worksheets("Accepted").Cells(j, 1).Value Then
            ActiveWorkbook.Worksheets("Accepted").Cells(j, 4).Value = ActiveWorkbook.Worksheets("Sheet1").Cells(i, 2).Value    
            End If
        Next i
    Next j

'to transfer recognised status to the recognised column and to remove from restricted column
'I think this is the section which contributes to the lag/delay
Restrictedlastrow = ActiveWorkbook.Worksheets("Accepted").Range("D" & Rows.Count).End(xlUp).Row
    For k = 9 To Restrictedlastrow
        If ActiveWorkbook.Sheets("Accepted").Cells(k, 4).Value <> "Restricted" Then
        ActiveWorkbook.Sheets("Accepted").Cells(k, 4).Copy ActiveWorkbook.Sheets("Accepted").Cells(k, 5)
        ActiveWorkbook.Sheets("Accepted").Cells(k, 4).ClearContents
        End If
    Next k


'to reset settings back to normal
With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With

Answer 1

代替

ActiveWorkbook.Sheets("Accepted").Cells(k, 4).Copy ActiveWorkbook.Sheets("Accepted").Cells(k, 5)

使用

ActiveWorkbook.Sheets("Accepted").Cells(k, 5) = ActiveWorkbook.Sheets("Accepted").Cells(k, 4)

复制是一项昂贵的操作。由于您似乎只对单元格的值感兴趣，因此直接分配它（就像您在前面的循环中所做的那样）。