嵌套循环导致Excel崩溃

Posted 2021-04-19

我试图运行一个VBA宏，迭代约67,000行，每行100列。对于这些行中的每个单元格，将该值与另一个工作表中具有87个条目的列进行比较。运行代码时没有注意到错误，但Excel每次都崩溃。奇怪的是代码似乎有效;我将它设置为标记找到匹配的每一行，并在崩溃之前执行此操作。我试图多次运行它并且在崩溃之前已经通过800到11,000行，具体取决于尝试。

我的第一个疑问是由于计算量导致内存溢出，但我的系统在运行此代码时显示CPU利用率为100％，内存使用率为50％左右：

Sub Verify()

    Dim codes As String
    Dim field As Object

    For i = 2 To Sheets("DSaudit").Rows.Count
        For Each field In Sheets("Dsaudit").Range(Cells(i, 12), Cells(i, 111))
            r = 1
            While r <= 87
                codes = ThisWorkbook.Sheets("287 Denominator CPT").Cells(r, 1).Value
                If field = codes Then
                    Cells(i, 112).Value = "True"
                r = 88
                Else
                    r = r + 1
                End If
            Wend
        Next field
        i = i + 1
    Next i
End Sub

还应该指出的是，我对VBA仍然很新，所以很可能我犯了一些令人震惊的菜鸟错误。我可以对此代码进行一些更改以避免崩溃，还是应该废弃它并采取更有效的方法？

答案

什么时候可以迭代变量数组。这限制了vba访问工作表所需的次数。

每次vba和Excel之间的面纱都需要花费时间。这只能刺穿面纱3次而不是9,031,385,088

Sub Verify()


    With Sheets("DSaudit")

        'Get last row of Data
        Dim lastrow As Long
        lastrow = .Cells(.Rows.Count, 12).End(xlUp).Row 'if column 12 ends before the last row of data change to column that has them all.

        'Load Array with input Values
        Dim rng As Variant
        rng = .Range(.Cells(2, 12), .Cells(lastrow, 111)).Value

        'Create output array
        Dim outpt As Variant
        ReDim outpt(1 To UBound(rng, 1), 1 To 1)

        'Create Match array
        Dim mtch As Variant
        mtch = Worksheets("287 Denominator CPT").Range("A1:A87").Value

        'Loop through first dimension(Row)
        Dim i As Long
        For i = LBound(rng, 1) To UBound(rng, 1)
            'Loop second dimension(Column)
            Dim j As Long
            For j = LBound(rng, 2) To UBound(rng, 2)
                'Loop Match array
                Dim k As Long
                For k = LBound(mtch, 1) To UBound(mtch, 1)
                    'If eqaul set value in output and exit the inner loop
                    If mtch(k, 1) = rng(i, j) Then
                        outpt(i, 1) = "True"
                        Exit For
                    End If
                Next k
                'If filled true then exit this for
                If outpt(i, 1) = "True" Then Exit For
            Next j
        Next i

        'Assign the values to the cells.
        .Cells(2, 112).Resize(UBound(outpt, 1), 1).Value = outpt
    End With

 End Sub