Question

我有一个宏（下图），设计为在结束前运行150,000次迭代。但是，在我运行代码超过1,000次迭代后，Excel进入“无响应”模式，然后崩溃。我已经离开它超过12个小时，但它没有变得更好。该代码以前曾用于运行前100,000次迭代，并且需要以250,000次为单位运行多达1,048,576次迭代。

崩溃还会导致Outlook，IE以及Chrome（尽管我已经停止同时运行它们，但仍然崩溃）。

如果我通过F8运行代码，或通过F5运行检查点，代码运行正常。但是，这对于另外948,576次迭代来说是不切实际的。

有关如何解决问题的任何建议，所以它不会一直崩溃吗？

系统规格如下： Excel 2010 i5（第3代） 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

Answer 1

这只花了不到5秒的时间来填充10中的12列。这可能是因为我的大部分工作表都是空的，但是如果你关闭计算/屏幕更新，它会更快。

它不会填充的唯一两列是C和D。您不能使用公式方法，因为它超出了If条件要求。你可以为那些2写一个小循环。

无需从行100001循环到250000，也无需从列1循环到12。您可以一次性在这些单元格中输入公式。这是一个例子

Sub Sample()
    '~~> When a = 1 i.e 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

当我运行此代码时，这就是我得到的

Answer 2

这是我在前面的评论中讨论过的变体内存处理。虽然早期的公式方法实际上要慢一些，但它也更完整;特别是使用字典对象来计算countifs。

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

我的示例数据暂时可用here。在与我们自己的配置非常相似的旧i5商务级笔记本电脑上经过的时间约为13秒。

Excel 2010在超过X个循环后不断崩溃

2 个答案: