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

嵌套循环导致Excel崩溃

1 个答案: