Improve Excel macro that runs slowly

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?

Sub Export_Updates()

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

Any suggestions welcome.

Answer 1

I'd suggest using VBA arrays to do the processing. Going between the Excel environment and the VBA environment is a slow process, and you are doing it multiple times for each row of data. There is a little more programming involved with using VBA arrays, but the speed difference can be significant (32x as fast for a sample of 60K rows).

In general, it is best practice to

1. Read all data from Excel to VBA array in one step, using a 2-D array
2. Process the data in VBA, storing the results in another VBA array
3. At the very end, transfer the VBA array back to Excel

Here is an example workbook showing some more specifics.

And here is the faster VBA code:

Sub Method2()
    Dim ws As Worksheet
    Dim wsOutput As Worksheet
    Dim rngRawData As Range
    Dim rngOutput As Range
    Dim rngToDelete As Range
    Dim vaRawData() As Variant
    Dim vaDiffs() As Variant

    t = Timer

    Set ws = ActiveSheet
    Set rngRawData = ws.Range("A1").CurrentRegion
    ' Transfers Excel data to a VBA array in one step.
    vaRawData = rngRawData

    'Loop through the VBA array, adding any No Match entries to the Diffs array
    ReDim vaDiffs(rngRawData.Rows.Count, 1 To 3)
    iDiffs = 0
    For i = LBound(vaRawData, 1) To UBound(vaRawData, 1)
    If vaRawData(i, 4) = "No Match" Then
        iDiffs = iDiffs + 1
        vaDiffs(iDiffs, 1) = vaRawData(i, 1) ' Capture the ID
        vaDiffs(iDiffs, 2) = vaRawData(i, 2) ' Capture the Source1 Value
        vaDiffs(iDiffs, 3) = vaRawData(i, 3) ' Capture the Source 2 value
    End If
    Next i

    'Transfer the Diffs array back to excel
    Set wsOutput = Worksheets("Diff2")
    wsOutput.Range("A1") = vaDiffs

    'Delete extra rows
    wsOutput.Cells(iDiffs + 2, 1) = "END"
    Set rngToDelete = wsOutput.Range(wsOutput.Cells(iDiffs + 2, 1), _
    wsOutput.Cells(rngRawData.Rows.Count + 3, 1))
    rngToDelete.EntireRow.Delete

    wsOutput.Activate
    MsgBox "It took " & Timer - t & " seconds."
End Sub

Answer 2

Here's an example that will quickly place all the contents of the cells of a worksheet into an array. This will allow you to process the information much more quickly than using lots of cells references. Trust me, I have a workbook of over 100K rows that I have to read in for a number of projects and I used to iterate through it to read it, now I just do this and it took the total time to bring it in down from a minute or two to seconds.

Dim WS As Excel.Worksheet
Set WS = Excel.Workbooks(somebook).Worksheets(someworksheet)
Dim arr() as variant
arr = WS.UsedRange.Value

And there you have it. The best part is the reference stay the same. So what you used to get using

wb2.Worksheets("AD UPDATE").Cells(i, 1)

you can now get using

arr(i, 1)

or whatever you choose to name the array. It's made lots of my projects more performant.