Ways to improve macros execution time - vba

Question

I have created a macro, which runs fine but, for no reason I can explain, takes so long to finish. I have tried running the macro line to line and cannot figure out which part of the process takes so long. I can only imagine that it is the part where I delete rows based on backround color. I have built several macros with similar lines of code and the performance was way better.
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