VBA macro results in Excel freezing

Question

I have created a simple vba macro to iterate over 2 tabs in excel. Each tab will always be the same length. Currently, each tab is about 155,000 rows. I do not expect the tabs to ever be above 200,000 rows.

In the code below, the max number for any of the x's is 3,000. (200,000 * 3,000) = 600,000,000, which I believe a variant can handle.

The issue is that when I run the macro excel freezes. I assumed this was not too many rows for excel to handle, but maybe that is not true. When I reduce the number of rows, the macro completes as expected.

Is there a better solution for this code?

I am using 64-bit excel 2016 on a 64-bit machine.

FYI: I added the ROUND function because I thought all the extra decimals may have been causing the freeze.

Sub index_check()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.StatusBar = "Calculating indices"

Dim lastrow_Sheet1 As Double, lastrow_Sheet2 As Double
Dim deriv As String
Dim x1_indexcounter As Variant, x2_indexcounter As Variant, x3_indexcounter As Variant, x4_indexcounter As Variant, x5_indexcounter As Variant
Dim x1_derivcounter As Double, x2_derivcounter As Double, x3_derivcounter As Double, x4_derivcounter As Double, x5_derivcounter As Double
Dim rng_lostpolicies As Range, rng_foundindicies As Range, rng_mktData As Range
Dim mktData() As Double

Start = Now()

lastrow_Sheet1 = ThisWorkbook.Sheets("Sheet1").Range("A:A").Find("*", , , , , xlPrevious).Row
lastrow_Sheet2 = ThisWorkbook.Sheets("Sheet2").Range("A:A").Find("*", , , , , xlPrevious).Row

Set rng_lostpolicies = Application.Range("rng_lostpolicies")
Set rng_foundindicies = Application.Range("rng_foundindicies")
Set rng_mktData = Application.Range("rng_mktData")
ReDim mktData(rng_mktData.Cells.Count)

x1_indexcounter = 0
x2_indexcounter = 0
x3_indexcounter = 0
x4_indexcounter = 0
x5_indexcounter = 0
x1_derivcounter = 0
x2_derivcounter = 0
x3_derivcounter = 0
x4_derivcounter = 0
x5_derivcounter = 0

foundflag = "False"
m = 0
f = 0

For i = 1 To lastrow_Sheet1 - 1
    deriv = Trim(ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 1).Value)
        For j = 1 To lastrow_Sheet2 - 1
            If deriv = Trim(ThisWorkbook.Sheets("Sheet2").Cells(j + 1, 3)) Then
                If Trim(ThisWorkbook.Sheets("Sheet2").Cells(j + 1, 12)) = "x1" Then
                    x1_indexcounter = Round(x1_indexcounter + ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 2), 4)
                    x1_derivcounter = x1_derivcounter + 1
                ElseIf Trim(ThisWorkbook.Sheets("Sheet2").Cells(j + 1, 12)) = "x2" Then
                    x2_indexcounter = Round(x2_indexcounter + ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 2), 4)
                    x2_derivcounter = x2_derivcounter + 1
                ElseIf Trim(ThisWorkbook.Sheets("Sheet2").Cells(j + 1, 12)) = "x3" Then
                    x3_indexcounter = Round(x3_indexcounter + ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 2), 4)
                    x3_derivcounter = x3_derivcounter + 1
                ElseIf Trim(ThisWorkbook.Sheets("Sheet2").Cells(j + 1, 12)) = "x4" Then
                    x4_indexcounter = Round(x4_indexcounter + ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 2), 4)
                    x4_derivcounter = x4_derivcounter + 1
                ElseIf Trim(ThisWorkbook.Sheets("Sheet2").Cells(j + 1, 12)) = "x5" Then
                    x5_indexcounter = Round(x5_indexcounter + ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 2), 4)
                    x5_derivcounter = x5_derivcounter + 1
                Else
                    MsgBox "There is a new index for derivative id " & deriv
                    f = f + 1

                    If f > 10000 Then ' 10000 is an arbitrary number.
                        MsgBox "There are more than 10000 policies with a new index. Fix macro and rerun. Exiting macro."
                        Exit Sub
                    Else
                        rng_foundindicies.Offset(f, 0) = deriv
                    End If
                End If

            foundflag = "True"
            Exit For
            End If
        Next j

    If foundflag = "False" Then
        MsgBox "Could not find Derivative " & deriv & " in Sheet2 file, but it is in Sheet1 file."
        m = m + 1
        rng_lostpolicies.Offset(m, 0) = deriv
    End If
Next i



mktData(1) = check(x1_indexcounter, x1_derivcounter)
mktData(2) = check(x4_indexcounter, x4_derivcounter)
mktData(3) = check(x2_indexcounter, x2_derivcounter)
mktData(4) = check(x3_indexcounter, x3_derivcounter)
mktData(5) = check(x5_indexcounter, x5_derivcounter)

For i = 1 To UBound(mktData)
    rng_mktData.Cells(1, i).Offset(1, 0).Value = mktData(i)
Next i

MsgBox ("This check took " & Format(Now() - Start, "hh:mm:ss"))
Application.StatusBar = "Done"

End Sub

Public Function check(number1, number2)
    If number2 = 0 Then
        check = 0
    Else
        check = number1 / number2
End If

End Function

Have you attempted to load the data into an array? 600 million worksheet transactions is not a situation you want to be creating. — Zerk, Apr 23 '18 at 13:52
Every *n* loops (50? 100?), call `DoEvents`, so that Excel can check-in and tell Windows that it's still busy, not crashed. Consider using `Application.StatusBar` to show you a progress update at the same time. — Chronocidal, Apr 23 '18 at 13:59
At start you have `Application.ScreenUpdating = False`, but you never cancel it. So no more refresh of the screen. — Vincent G, Apr 23 '18 at 13:59
You never change `Application.Calculation = xlCalculationManual` back ether. — Vincent G, Apr 23 '18 at 14:00
You say *when I run the macro excel freezes*. are you sure of that? Test it. After the line `For i = 1 To lastrow_Sheet1 - 1` insert. `Application.StatusBar="Checking row " & i & " of " & lastrow_Sheet1 - 1`, so you can see what row causes the freeze. — Foxfire And Burns And Burns, Apr 23 '18 at 14:04
Also - would it be *far* faster to just use a Filter on Sheet2 for "x1" / "x2" / "x3" etc, and then count the [`.SpecialCells(xlCellTypeVisible)`](https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-specialcells-method-excel) in a column to get the `*_derivcounter` and multiply that by the index instead of looping through *every* row in Sheet2? — Chronocidal, Apr 23 '18 at 14:04
@VincentG - I don't think changing back ScreenUpdating or Calculation will solve the issue. When the macro is running, the Task Manager says excel is "Not responding." — haas, Apr 23 '18 at 14:07
@Chronocidal - I need to match the rows on Sheet1 and Sheet2 — haas, Apr 23 '18 at 14:08
@Zerk - Do you have an example of how this situation could use an array? In regards to 600 million - I was only pointing out that the max value of any on the variant counters would reach 600 million, which I believe a variant should be able to handle. — haas, Apr 23 '18 at 14:10
600 millions can be handled by Long, Single and Double. No need of variant. — Foxfire And Burns And Burns, Apr 23 '18 at 14:12
@haas Have you considered `WorksheetFunction.Match`? If we can reduce your code to just 1 loop, then we speed your code up by a factor of **155000** - I'm sure you can understand why this is appealing! (or 2 completely seperate non-nested loops for a factor of 77500) — Chronocidal, Apr 23 '18 at 14:15
Also, not sure, but variables like `x1_indexcounter` are Variant, but your sentence is `x1_indexcounter = Round(x1_indexcounter + ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 2), 4)`. So `x1_indexcounter` starts at 0 and then you sum the value of each cell if the criteria `x1` is met. That sounds like a SUMIF for me. I know your data is on different pages, but maybe you could do something different. — Foxfire And Burns And Burns, Apr 23 '18 at 14:44
The real problem is, that you have way to many read/write operations to and from Excel. This is extremely slow compared to in memory operations. You should load the two Tables into 2D Arrays and do the manipulations within VBA and post the results back ONCE in the end — FloLie, Apr 23 '18 at 14:49
Also for operations like this, you should def. take a look at PowerQuery, as it is very efficient for database operations as merges and aggregations — FloLie, Apr 23 '18 at 14:52
Can you post some data example, and also the output you want to get? — Foxfire And Burns And Burns, Apr 23 '18 at 15:09
*600 MILLION* Worksheet operations - **Holy Big Data Batman** you really need to copy your sheet data to arrays, and loop through them in memory... Alternatively, query your worksheets [using ADO](https://technet.microsoft.com/en-us/library/ee692882.aspx?f=255&MSPPError=-2147217396) — Our Man in Bananas, Apr 23 '18 at 15:22
Also, your `For j = 1 To lastrow_Sheet2 - 1`, what it does is try to find the first coincidence that mets criteria `deriv` to get the row number. That can get done by the function `MATCH`, as @Chronocidal said before . Probably, a formula like `MATCH("deriv criteria";Range("Rangeofdata");0)+ROW(Range("Rangeofdata"))-1` will get you the row number you want, to increase the value of your indexcounters. I'm pretty sure you could handle this with MATCH and SUMIF, but probably in array formulas. — Foxfire And Burns And Burns, Apr 23 '18 at 15:23
@haas: [here](https://stackoverflow.com/questions/18481330/2-dimensional-array-from-range) is a good example of using arrays to handle worksheet data by meehow i — Our Man in Bananas, Apr 23 '18 at 15:27

score 0 · Accepted Answer · answered Apr 24 '18 at 14:25

Thanks all for the help. The match function is allowing the macro to complete; albeit slowly. It still takes about 10-20 minutes to complete, depending on the machine. This works for now but will post an update if a more efficient solution is found.

For i = 1 To lastrow_Sheet1 - 1
    deriv = Trim(ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 1).Value)

        deriv_row = Application.WorksheetFunction.Match(deriv, ThisWorkbook.Sheets("Sheet2").Range("C:C"), 0)

        If IsError(deriv_row) Then
            MsgBox "Could not find Derivative " & deriv & " in Sheet2 file, but it is in Sheet1 file."
            m = m + 1
            rng_lostpolicies.Offset(m, 0) = deriv
            GoTo ErrorHandler
        End If

                If Trim(ThisWorkbook.Sheets("Sheet2").Cells(deriv_row, 12)) = "x1" Then
                    x1_indexcounter = Round(x1_indexcounter + ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 2), 4)
                    x1_derivcounter = x1_derivcounter + 1
                ElseIf Trim(ThisWorkbook.Sheets("Sheet2").Cells(deriv_row, 12)) = "x2" Then
                    x2_indexcounter = Round(x2_indexcounter + ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 2), 4)
                    x2_derivcounter = x2_derivcounter + 1
                ElseIf Trim(ThisWorkbook.Sheets("Sheet2").Cells(deriv_row, 12)) = "x3" Then
                    x3_indexcounter = Round(x3_indexcounter + ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 2), 4)
                    x3_derivcounter = x3_derivcounter + 1
                ElseIf Trim(ThisWorkbook.Sheets("Sheet2").Cells(deriv_row, 12)) = "x4" Then
                    x4_indexcounter = Round(x4_indexcounter + ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 2), 4)
                    x4_derivcounter = x4_derivcounter + 1
                ElseIf Trim(ThisWorkbook.Sheets("Sheet2").Cells(deriv_row, 12)) = "x5" Then
                    x5_indexcounter = Round(x5_indexcounter + ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 2), 4)
                    x5_derivcounter = x5_derivcounter + 1
                Else
                    MsgBox "There is a new index for derivative id " & deriv
                    f = f + 1

                    If f > 10000 Then ' 10000 is an arbitrary number.
                        MsgBox "There are more than 10000 policies with a new index. Fix macro and rerun. Exiting macro."
                        Exit Sub
                    Else
                        rng_foundindicies.Offset(f, 0) = deriv
                    End If
                End If

ErrorHandler:                            
    Next i

10-20 minutes with around 155.000 rows sounds pretty good to me :). Anyways, if you could post some data and the output maybe somebody can improve the code. — Foxfire And Burns And Burns, Apr 26 '18 at 09:17

VBA macro results in Excel freezing

1 Answers1