More efficient update macro in Excel

Question

I have a macro that makes comparisons and then this macro exports all of the changes based on if the information doesn't match. I have it so that each column gets their own worksheet in the new workbook. I am using 7 different counting integers and it takes a very long time because I am exporting over 60k rows.

Question: is there a faster way to execute this code? Can a UDF be used? if so how?

Dim ws As Worksheet
Dim wb2 As Workbook
Set wb = Application.Workbooks("Total Database Update_WORKING.xlsm")
Set ws = wb.Worksheets("Results")
Set wb2 = Application.Workbooks.Open("C:\Import Update.xlsx")
 i = 2
 ii = 2
 iii = 2
 iiii = 2
 iiiii = 2
 iiiiii = 2
 iiiiii = 2
 k = 2
 wb2.Activate
 Do While ws.Cells(k, 1) <> ""
 If ws.Cells(k, 4) = "No Match" Then
 wb2.Worksheets("AD UPDATE").Cells(i, 1) = ws.Cells(k, 1)
 wb2.Worksheets("AD UPDATE").Cells(i, 2) = ws.Cells(k, 2)
 i = i + 1
 End If
 If ws.Cells(k, 7) = "No Match" Then
 wb2.Worksheets("SENIOR UPDATE").Cells(ii, 1) = ws.Cells(k, 1)
 wb2.Worksheets("SENIOR UPDATE").Cells(ii, 2) = ws.Cells(k, 5)
 ii = ii + 1
 End If
 If ws.Cells(k, 10) = "No Match" Then
 wb2.Worksheets("ID UPDATE").Cells(iii, 1) = ws.Cells(k, 1)
 wb2.Worksheets("ID UPDATE").Cells(iii, 2) = ws.Cells(k, 8)
 iii = iii + 1
 End If
 If ws.Cells(k, 13) = "No Match" Then
 wb2.Worksheets("MINOR UPDATE").Cells(iiii, 1) = ws.Cells(k, 1)
 wb2.Worksheets("MINOR UPDATE").Cells(iiii, 2) = ws.Cells(k, 11)
 End If
 If ws.Cells(k, 16) = "No Match" Then
 wb2.Worksheets("MAJOR UPDATE").Cells(iiii, 1) = ws.Cells(k, 1)
 wb2.Worksheets("MAJOR UPDATE").Cells(iiii, 2) = ws.Cells(k, 14)
 iiii = iiii + 1
 End If
 If ws.Cells(k, 19) = "No Match" Then
 wb2.Worksheets("CAP UPDATE").Cells(iiiii, 1) = ws.Cells(k, 1)
 wb2.Worksheets("CAP UPDATE").Cells(iiiii, 2) = ws.Cells(k, 17)
 iiiii = iiiii + 1
 End If
 If ws.Cells(k, 22) = "No Match" Then
 wb2.Worksheets("PL UPDATE").Cells(iiiiii, 1) = ws.Cells(k, 1)
 wb2.Worksheets("PL UPDATE").Cells(iiiiii, 2) = ws.Cells(k, 20)
 iiiiii = iiiiii + 1
 End If
 k = k + 1
 Loop
 wb2.Save
 Sleep (1000)
 wb2.Close SaveChanges:=True
 wb.Activate
End Sub

• Zaider: One thing you could do to speed up looping would be dump your sheet into an array and loop that.
• user3271518: I tried that but I keep getting Object not defined when I try to use a range in an array. Is there a specific way to do that?

Answer 1

i = 2
ii = 2
iii = 2
iiii = 2
iiiii = 2
iiiiii = 2
iiiiii = 2

Doesn't that smell like... something that doesn't smell good?

You haven't listed the entire module, so this might be a non-issue, from the code you posted but you're not declaring all the variables you're using. Systematically stick an Option Explicit at the top of every module - the code won't run if a non-declared identifier is used anywhere.

Naming things is hard, but bad naming is harmful, and in some cases can reveal structural issues.

When you feel the need to stick a "2" and then a "3" as a suffix to a given identifier, a shiny red flag raises and says you shouldn't be doing that, there has to be a better way... this flag is your subconscious, telling you to split your procedure into multiple, smaller ones.

Let's look at a single block:

 If ws.Cells(k, 4) = "No Match" Then
 wb2.Worksheets("AD UPDATE").Cells(i, 1) = ws.Cells(k, 1)
 wb2.Worksheets("AD UPDATE").Cells(i, 2) = ws.Cells(k, 2)
 i = i + 1
 End If

Several "magic values" can become parameters, if we were to see this repeated code block as a function of its own; the parameters would be:

• { "AD UPDATE", 4, 2 }
• { "SENIOR UPDATE", 7, 5 }
• { "ID UPDATE", 10, 8 }
• { "MINOR UPDATE", 13, 11 }
• { "MAJOR UPDATE", 16, 14 }
• { "CAP UPDATE", 19, 17 }
• { "PL UPDATE, 22, 20 }

Given how these values are used, the corresponding parameter names could be sheetName, matchColumn, and destinationColumn.

i & friends are in fact row counters. This means a method extracted from that code block could look like this:

Private Function SayWhatYouDoDoWhatYouSay(ByRef sourceSheet As Worksheet, _
 ByRef destinationBook As Workbook, _
 ByVal sheetName As String, _
 ByVal sourceRow As Long, _
 ByVal matchColumn As Long, _
 ByVal destinationColumn As Long, _
 ByVal destinationRow As Long) As Long
 Set destinationSheet = destinationBook.Sheets(sheetName)
 If sourceSheet.Cells(sourceRow, matchColumn) = "No Match" Then
 destinationSheet.Cells(destinationRow, 1) = sourceSheet.Cells(sourceRow, 1)
 destinationSheet.Cells(destinationRow, destinationColumn) = sourceSheet.Cells(sourceRow, 2)
 destinationRow = destinationRow + 1
 End If
 SayWhatYouDoDoWhatYouSay = destinationRow
End Function

Notice how sourceRow is much more meaningful than k, and destinationRow than i (or iiiiii); the function returns a new value for destinationRow, which the caller can use to assign a new value for the next destination row.

You could maintain an array of Long (Integer?) values for that:

 Dim destinationRow(0 To 6) As Long

This gives you 7 "slots", one for each update type. To be nice you could give each value a meaningful name as well, with an enum type:

Public Enum UpdateType
 AdUpdate = 0,
 SeniorUpdate,
 IdUpdate,
 MinorUpdate,
 MajorUpdate,
 CapUpdate,
 PlUpdate
End Enum

And then in the original loop, instead of the multiple If blocks:

destinationRow(UpdateType.AdUpdate) = SayWhatYouDoDoWhatYouSay(ws, wb2, "AD UPDATE", k, 4, 2, destinationRow(UpdateType.AdUpdate))
destinationRow(UpdateType.SeniorUpdate) = SayWhatYouDoDoWhatYouSay(ws, wb2, "SENIOR UPDATE", k, 7, 5, destinationRow(UpdateType.SeniorUpdate))
...

Answer 2

What are the chances that more than one of your if statements would be true for each row? It looks like you may risk overwriting some of your data if that is the case.

Dim ws As Worksheet
Dim wb2 As Workbook
Set wb = Application.Workbooks("Total Database Update_WORKING.xlsm")
Set ws = wb.Worksheets("Results")

Using variant your array will be able to size to whatever range you give it, but it will be 1 based.

Dim rng as Variant
Set rng = wb.worksheetS("Results").Range("B2:Your last column/row goes here")
Set wb2 = Application.Workbooks.Open("C:\Import Update.xlsx")
 i = 2
 ii = 2
 iii = 2
 iiii = 2
 iiiii = 2
 iiiiii = 2
 iiiiii = 2
 k = 2
 wb2.Activate
 dim row as long
 dim col as long
 For row = 1 to UBound(rng, 1)
 If rng(row, 4) = "No Match" Then
 wb2.Worksheets("AD UPDATE").Cells(i, 1) = rng(row, 1)
 wb2.Worksheets("AD UPDATE").Cells(i, 2) = rng(row, 2)
 i = i + 1
 End If 
 k = k + 1
 Next Row
 wb2.Save
 Sleep (1000)
 wb2.Close SaveChanges:=True
 wb.Activate
End Sub