Macro that combines data from multiple worksheets

Question

I have created a macro to combine data from different excel sheets into one final report. As it is obvious from the code provided below, there are very clear steps in the code. The code has no issues (it runs as intended) but it takes so long to execute.

I have written many macros similar to this one and they normally run really fast. The three sheets that the macro is using have no more than 700 lines. I have tried to check step by step the code to figure out where there might be the issue for the delay and I think the issue is in the part of the code where I delete the rows based on their background color.

Any suggestions how to fix the speed issues?

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

EDIT

I am sorry for not being more precise.. I have narrowed down the possible parto f the code which causes delay. That part is definitelly the part of deleting rows based on the background color of a cell. So to avoid confusion I am going to focus only on that part. I am providing the part of the code below. What I am actually trying to do is this: I have copied and pasted a range of cells from one sheet to the one I want to edit. That range of cells has rows and columns (of course). What I want the macro to do is go throuth column D and check the cells background color. If there is a background color besides white, I want the macro to delete the entire row that the cell belongs to. So as a final result I want the macro to keep only rows in which the cell in column D has either no fill or white background color. The code as provided below performs that task as it is supposed to, but takes so much time. The total number of rows that the macro prosecces is 700. Any propositions for making it faster.

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

Answer 1

Firstly, Using colorindex might cause issues on different systems. Instead, use the RGB() method.

I don't quite understand the use of Union - why do you need it? Just iterate from the bottom upwards and delete as you go -

For rowNumber = lastRow To 2 Step -1
    If Sheet1.Cells(rowNumber, 1).Interior.Color = RGB(255, 255, 255) Then Sheet1.rowNumber.EntireRow.Delete Shift:=xlShiftUp
Next

It's good practice to indent all of your code that way Labels will stick out as obvious.

Variables

Always turn on Option Explicit. You can have it automatically by going to Tools -> Options in the VBE and checking the Require Variable Declaration option. This way if you have any variables not defined, the compiler will let you know.

When you don't define your variable, VBA will declare it as a Variant type that can hold any type of data. While this may be more flexible, it adds processing time to your macro as VBA decides or tests for the type. Additionally, since a Variant can be any type of data, you may miss out on valuable troubleshooting information on Type Mismatch. You didn't declare spath1 or spath2.

Variable names - give your variables meaningful names and use Standard VBA naming conventions have camelCase for local variables and PascalCase for other variables and names.

So DeleteRange should be deleteRange and lastrow1 would be lastRow1.

But you have numbers in your variables names - this is a clue that your names could be better. Ask yourself - what is lastrow1 and lastrow2? I mean lastrow1 is the last row on ws2 and lastrow2 is the last row on ws1 - that's incredibly confusing, don't you think? Why not stockLastRow and orderLastRow or something?

Worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("mySheet") and instead just use mySheet.

You have two paths, those seem like they would not change, so you can make them constants:

Const PATH_TO_REPLENISH As String = "PATH\TO\FILE"

You also have sheets set to different books, but no indication in the variables that that is the case.

---

Copy and paste?

Be sure to avoid things like .Select - it just slows the code down by needing to fiddle with the spreadsheet while doing everything else behind the scenes. There's a good question on StackOverflow addressing this. You copy and paste because you need the formats, right? You can figure out a better way to do that, I think.

Maybe you look at the interior colors before you copy, only copying the values you need. But do you need the colors on the final product? You have an index you created and you can copy those back at the end, or you can create a second array of those values. Maybe the colors don't matter once you sort out what you need? Then that's an entire process you can eliminate!