Question

我创建了一个宏，该宏运行良好，但出于我无法解释的原因，它需要很长时间才能完成。我尝试将宏行逐行运行，但无法弄清楚过程的哪一部分花费了这么长时间。我只能想象这是我根据背景色删除行的部分。我用相似的代码行构建了几个宏，并且性能要好得多。

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

缩短宏执行时间的方法

0 个答案: