Excel 2010 continues to crash after more than X number of cycles

Question

I have a macro (below) that is designed to run 150,000 iterations to completion. However, after running the code for more than 1000 iterations, Excel enters "Not Responding" mode, and then crashes. I left it for more than 12 hours, but it did not improve. Previously, the code was used to run the first 100,000 iterations and to run up to 1,048,576 iterations in steps of 250,000.

Failure also leads to disabling Outlook, IE, as well as to Chrome (although I did not start them at the same time, but still a failure).

If I run the code through F8 or to a breakpoint through F5, the code works fine. However, this is impractical for another 948 576 iterations.

Any suggestions on how to solve the problem so that it doesn't crash all the time?

System Specifications: Excel 2010 i5 (3rd Gene) RAM 8GB

code:

Dim a As Variant Dim b As Variant Dim c As Variant Dim d As Variant Dim e As Variant Dim i As Integer Dim j As Double Dim strResult As Double a = 1 b = 100001 While b <= 250000 While a <= 12 If a = 1 Then If Cells(b, 14) = "EEEE" Then Cells(b, a) = 1234 ElseIf Cells(b, 14) = "ZYXW" Then Cells(b, a) = 2468 ElseIf Cells(b, 14) = "AAAA" Then Cells(b, a) = 3579 ElseIf Cells(b, 14) = "BBBB" Then Cells(b, a) = 9764 ElseIf Cells(b, 14) = "DDDD" Then Cells(b, a) = 8631 Else Cells(b, a) = "ZZZZ" End If ElseIf a = 2 Then If Cells(b, 15) = 5 Then Cells(b, a) = "JPY" ElseIf Cells(b, 15) = 4 Then Cells(b, a) = "GBP" ElseIf Cells(b, 15) = 3 Then Cells(b, a) = "CHF" ElseIf Cells(b, 15) = 2 Then Cells(b, a) = "USD" ElseIf Cells(b, 15) = 1 Then Cells(b, a) = "EUR" Else Cells(b, a) = "YYYY" End If ElseIf a = 3 Then If Cells(b, 16) = 10234 Then Cells(b, a) = "A27Z2" ElseIf Cells(b, 16) = 10420 Then Cells(b, a) = "B28Y" ElseIf Cells(b, 16) = 10432 Then Cells(b, a) = "C29X" ElseIf Cells(b, 16) = 18953 Then Cells(b, a) = "D30W" ElseIf Cells(b, 16) = 21048 Then Cells(b, a) = "E31V" ElseIf Cells(b, 16) = 36542 Then Cells(b, a) = "F32U" ElseIf Cells(b, 16) = 36954 Then Cells(b, a) = "G33T" ElseIf Cells(b, 16) = 65425 Then Cells(b, a) = "H34S" ElseIf Cells(b, 16) = 75963 Then Cells(b, a) = "I35R" ElseIf Cells(b, 16) = 84563 Then Cells(b, a) = "J36Q" Else Cells(b, a) = "XXXX" End If ElseIf a = 4 Then strResult = 1 For i = 1 To Len(Cells(b, 18)) Select Case Asc(Mid(Cells(b, 18), i, 1)) Case 65 To 90: strResult = strResult + Asc(Mid(Cells(b, 18), i, 1)) - 64 Case Else strResult = strResult + Mid(Cells(b, 18), i, 1) End Select Next j = WorksheetFunction.CountIfs(Range("A1:A" & b), Range("A" & b), Range("B1:B" & b), Range("B" & b)) Cells(b, a) = Cells(b, 1) & " - " & Cells(b, 2) & strResult & " - " & j ElseIf a = 5 Then Cells(b, a) = Cells(b, 17) ElseIf a = 6 Then If Cells(b, 19) = "SB" Then Cells(b, a) = "Sub" ElseIf Cells(b, 19) = "RD" Then Cells(b, a) = "Red" Else Cells(b, a) = "XXXX" End If ElseIf a >= 7 Then Cells(b, a) = Cells(b, a + 13) End If a = a + 1 Wend b = b + 1 a = 1 Wend Columns("M:Q").Select Selection.Delete Shift:=xlToLeft Columns("N:V").Select Selection.Delete Shift:=xlToLeft 

Answer 1

This is an in-memory processing option that I mentioned earlier in the comments. Although in fact it is slightly slower than the formula formula proposed earlier, it is also more complete; in particular, using a dictionary object to calculate countif.

 Option Explicit Sub bigRun() Dim a As Long, b As Long, i As Long, j As Long Dim c As Variant, d As Variant, e As Variant '<~~?????? Dim vals As Variant Dim ab As String, strResult As String Dim dABs As Object appTGGL Set dABs = CreateObject("Scripting.Dictionary") dABs.CompareMode = vbTextCompare With Worksheets("Sheet1") vals = .Range("A100001:Z250000").Value2 For b = 100001 To 250000 For a = 1 To 12 Select Case a Case 1 Select Case vals(b - 100000, 14) Case "EEEE" vals(b - 100000, a) = 1234 Case "ZYXW" vals(b - 100000, a) = 2468 Case "AAAA" vals(b - 100000, a) = 3579 Case "BBBB" vals(b - 100000, a) = 9764 Case "DDDD" vals(b - 100000, a) = 8631 Case Else vals(b - 100000, a) = "ZZZZ" End Select Case 2 Select Case vals(b - 100000, 15) Case 5 vals(b - 100000, a) = "JPY" Case 4 vals(b - 100000, a) = "GBP" Case 3 vals(b - 100000, a) = "CHF" Case 2 vals(b - 100000, a) = "USD" Case 1 vals(b - 100000, a) = "EUR" Case Else vals(b - 100000, a) = "YYYY" End Select Case 3 Select Case vals(b - 100000, 16) Case 10234 vals(b - 100000, a) = "A27Z2" Case 10420 vals(b - 100000, a) = "B28Y" Case 10432 vals(b - 100000, a) = "C29X" Case 18953 vals(b - 100000, a) = "D30W" Case 21048 vals(b - 100000, a) = "E31V" Case 36542 vals(b - 100000, a) = "F32U" Case 36954 vals(b - 100000, a) = "G33T" Case 65425 vals(b - 100000, a) = "H34S" Case 75963 vals(b - 100000, a) = "I35R" Case 84563 vals(b - 100000, a) = "J36Q" Case Else vals(b - 100000, a) = "XXXX" End Select Case 4 ab = Join(Array(vals(b - 100000, 1), vals(b - 100000, 2)), ChrW(8203)) If dABs.exists(ab) Then j = dABs.Item(ab) + 1 Else j = 1 End If dABs.Item(ab) = j strResult = 1 For i = 1 To Len(vals(b - 100000, 18)) Select Case Asc(Mid(vals(b - 100000, 18), i, 1)) Case 65 To 90: strResult = strResult + Asc(Mid(vals(b - 100000, 18), i, 1)) - 64 Case Else strResult = strResult + Mid(vals(b - 100000, 18), i, 1) End Select Next vals(b - 100000, a) = Join(Array(vals(b - 100000, 1), _ vals(b - 100000, 2), _ strResult, j), _ Chr(32) & Chr(45) & Chr(32)) Case 5 vals(b - 100000, a) = vals(b - 100000, 17) Case 6 Select Case vals(b - 100000, 19) Case "SB" vals(b - 100000, a) = "Sub" Case "RD" vals(b - 100000, a) = "Red" Case Else vals(b - 100000, a) = "XXXX" End Select Case 7 To 12 vals(b - 100000, a) = vals(b - 100000, a + 13) End Select Next a Next b .Range("A100001").Resize(UBound(vals, 1), UBound(vals, 2)) = vals '.Columns("M:Q").Delete Shift:=xlToLeft '.Columns("N:V").Delete Shift:=xlToLeft End With dABs.RemoveAll: Set dABs = Nothing appTGGL bTGGL:=False End Sub Public Sub appTGGL(Optional bTGGL As Boolean = True) With Application .ScreenUpdating = bTGGL .EnableEvents = bTGGL .DisplayAlerts = bTGGL .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual) End With Debug.Print Timer End Sub 

My sample data is temporarily available here . The elapsed time on an old i5 business-class laptop that accurately reflects your own configuration was ~ 13 seconds.

Answer 2

It just took me less than 5 seconds to fill in 10 of 12 columns. Perhaps this is due to the fact that most of my sheet was empty, but, nevertheless, if you turn off calculations / escaping, it will be faster.

Only two columns that it does not populate are C and D You cannot use the formulaic approach for it, since it exceeds the requirements of the If condition. You can write a small loop for these 2.

There is no need to 100001 over rows from row 100001 to 250000 and from columns 1 to 12 . You can enter the formula into these cells at a time. Here is an example

 Sub Sample() '~~> When a = 1 ie Col A range("A100001:A250000").Formula = "=IF(N100001=""EEEE"",""1234"",IF(N100001=""ZYXW"",""2468"",IF(N100001=""AAAA"",""3579"",IF(N100001=""BBBB"",""9764"",IF(N100001=""DDDD"",""8631"",""ZZZZ"")))))" range("B100001:B250000").Formula = "=IF(O100001=""5"",""JPY"",IF(O100001=""4"",""GBP"",IF(O100001=""3"",""CHF"",IF(O100001=""2"",""USD"",IF(O100001=""1"",""EUR"",""YYYY"")))))" '3,4 This needs to be coded range("E100001:E250000").Value = range("Q100001:Q250000").Value range("F100001:F250000").Formula = "=IF(S100001=""SB"",""Sub"",IF(S100001=""RD"",""Red"",""XXXX""))" For i = 7 To 12 range(Cells(100001, i), Cells(250000, i)).Formula = "=" & Cells(100001, i + 13).Address Next i End Sub 

When I ran this code, this is what I got