嵌套循环导致 Excel 崩溃

Question

我正在尝试运行一个 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 还是很陌生，所以我很可能犯了某种严重的新手错误。我可以对此代码进行一些更改以避免崩溃，还是应该废弃它并采取更有效的方法？

Answer 1

尽可能迭代变体数组。这限制了 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