Vba 提高宏执行时间的方法

我已经创建了一个宏，它运行得很好，但我无法解释，它需要很长时间才能完成。我试过逐行运行宏，但无法确定该过程的哪个部分需要这么长时间。我只能想象这是我根据背景颜色删除行的部分。我已经用类似的代码行构建了几个宏，性能要好得多

Sub Pharma_Stock_Report()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim lastrow3 As Long
Dim cell As Range
Dim DeleteRange As Range

spath1 = Application.ThisWorkbook.Path & "\Pharma replenishment.xlsm"
spath2 = Application.ThisWorkbook.Path & "\NOT OK.xlsx"
Workbooks.Open spath1
Workbooks.Open spath2

Set ws1 = Workbooks("Pharma Stock Report.xlsm").Worksheets("Pharma Stock Report")
Set ws2 = Workbooks("Pharma replenishment.xlsm").Worksheets("Replenishment")
Set ws3 = Workbooks("NOT OK.xlsx").Worksheets("Sheet1")

ws1.Cells.Clear

lastrow1 = ws2.Range("A" & Rows.Count).End(xlUp).Row
ws2.Range("A4:G" & lastrow1).Copy
With ws1.Range("A1")
    .PasteSpecial xlPasteColumnWidths
    .PasteSpecial xlPasteValues, , False, False
    .PasteSpecial xlPasteFormats, , False, False
End With

Application.CutCopyMode = False
Workbooks("Pharma replenishment.xlsm").Close

lastrow2 = ws1.Range("A" & Rows.Count).End(xlUp).Row
For Each cell In ws1.Range("D2:D" & lastrow2)
    If Not cell.Interior.ColorIndex = 2 Or cell.Interior.ColorIndex = -4142 Then
        If DeleteRange Is Nothing Then
            Set DeleteRange = cell
        Else
            Set DeleteRange = Union(DeleteRange, cell)
        End If
    End If
Next cell
If Not DeleteRange Is Nothing Then DeleteRange.EntireRow.Delete

ws3.Range("H1:J1").Copy
With ws1.Range("H1")
    .PasteSpecial xlPasteColumnWidths
    .PasteSpecial xlPasteValues, , False, False
    .PasteSpecial xlPasteFormats, , False, False
End With

lastrow3 = ws1.Range("D" & Rows.Count).End(xlUp).Row

ws1.Range("H2:H" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:H,3,FALSE),"""")"
With Range("H2:H" & lastrow3)
    .Value = .Value
    .NumberFormat = "dd/mm/yyyy"
End With

ws1.Range("I2:I" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE),"""")"
With Range("I2:I" & lastrow3)
    .Value = .Value
    .NumberFormat = "dd/mm/yyyy"
End With

ws1.Range("J2:J" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:J,5,FALSE),"""")"
With Range("J2:J" & lastrow3)
    .Value = .Value
    .NumberFormat = "dd/mm/yyyy"
End With

Application.CutCopyMode = False
Workbooks("NOT OK.xlsx").Close

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

---

由于这是工作代码，您将在编码风格和提高性能的方法方面获得建设性的帮助。如果您的代码工作正常，但需要调整，请展示并描述它的用途，它是做什么的，它是如何做的，它为什么这样做，给它一个标题，总结代码的用途，CR上的人会很乐意以各种可能的方式帮助您提高编码技能，包括性能。也许可以在不同的地方加入一些

Debug.Print Timer

，看看代码的速度有多慢。还可以提到每张工作表中包含多少行，和/或尽可能提供屏幕截图。我通常只需点击调试点的几个地方，然后点击播放。这样，您就可以直接缩小麻烦区域的范围-将vlookup（）粘贴到最后一行的位置或循环-最后一行是什么？