超过X个循环后，Excel 2010会一直崩溃
我有一个macros（下），旨在运行15万次迭代结束之前。 但是，我运行代码超过1000次迭代后，Excel将转到“无响应”模式，然后崩溃。 我已经离开了12个多小时，但没有任何好转。 之前的代码已经用来运行第一个100,000次迭代，并且需要运行多达1,048,576次迭代，分阶段为250,000次。
崩溃还带来了Outlook，IE，以及Chrome（虽然我已经停止在同一时间运行，但仍然崩溃）。
如果我通过F8运行代码或通过F5运行检查点，代码运行良好。 然而，这对于另外的948,576次迭代是不切实际的。
有关如何解决问题的任何build议，所以它不会不断崩溃？
系统规格是：Excel 2010 i5（第三代）8 GB RAM
码：
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 这是我之前在评论中讨论过的变体内存处理。 虽然之前提供的公式方法实际上稍微慢了一点，但它也更加完整。 特别是使用字典对象来计算标识符。
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
我的样本数据在这里暂时可用。 在一台老式的i5商务笔记本电脑上，经过了长达13秒的时间，
这只花了我不到5秒钟，填补10列中的10列。 这可能是因为我的大部分表单都是空的，但是如果你关掉计算/屏幕更新，它会更快。
只有两列它不填充是C和D 您不能使用公式方法，因为它超过了If条件要求。 你可以为这两个人写一个小循环。
没有必要从第100001行到第250000行以及从第1列到第12列循环。 您可以在这些单元格中一次input公式。 这是一个例子
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
当我运行这个代码时，这就是我所得到的
