VBA优化3个循环的性能

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

但是，由于“Sheet1”的B列中有2个可能的值，所以我想将这些值分成两列“Accepted” – 列D和E.因此，下一个循环，如果列D中的值为“接受“不是”限制“，然后将该值复制到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) 

复制是一个昂贵的操作。 因为你似乎只对单元格的值感兴趣，所以直接赋值（就像你在前面的循环中做的那样）。