比较两列 VBA 宏时 Excel 崩溃答案

【问题标题】：Excel crashes when comparing two columns VBA macro比较两列 VBA 宏时 Excel 崩溃
【发布时间】：2016-05-17 09:00:34
【问题描述】：

我有两列用于比较相同的条目，并通过 Offset 将匹配项推送到另一列。当我运行我构建的宏（使用一些 Microsoft 罐头代码）时，它基本上会冻结和崩溃，因为它是基于所使用的单元格的每个循环的嵌套，我认为它会在到达一个空单元格时结束，但是我担心我可能会陷入无限循环。任何帮助都感激不尽。

Dim myRng As Range
Dim lastCell As Long

Dim lastRow As Long
lastRow = ActiveSheet.UsedRange.Rows.Count

Dim c As Range
Dim d As Range

For Each c In Worksheets("Sheet1").Range("AT2:AT" & lastRow).Cells
    For Each d In Worksheets("Sheet1").Range("AU2:AU" & lastRow).Cells
        If c = d Then c.Offset(0, 1) = c
    Next d
Next c

【问题讨论】：

多少行？换句话说，什么是lastrow？它可能不是无限循环，但可能需要几分钟，具体取决于行数。因为你的迭代是 (lastrow -1)^2.
您的偏移量是正确的。它向右移动 1。
100,000 行是 1,000,000,000 次迭代，需要几分钟才能完成。你可能需要让它运行。虽然执行一个循环并使用 Range.Find 而不是第二个循环可能会更快。
搜索“Worksheet bloat” - 如果您受到此影响，那么您使用的范围将比您想象的要大得多。我总是使用通配符搜索来查找真正的最后一行，而不是使用使用的范围。
我会推荐 @ScottCraner 使用 range.find 的方法。你可以了解更多here。

标签： vba excel

【解决方案1】：

试试这个：

Dim lastRow, currentRow, compareRow As Long
Dim found As Boolean

lastRow = Range("AT2").End(xlDown).Row

For currentRow = 2 To lastRow
    compareRow = 2
    found = False
    Do While compareRow <= lastRow And Not found
        If Range("AT" & currentRow).Value = Range("AU" & compareRow).Value Then
            found = True
            Range("AV" & currentRow).Value = Range("AT" & currentRow).Value
        End If
        compareRow = compareRow + 1
        DoEvents
    Loop
Next currentRow

而不是选择范围然后循环通过它们，这做同样的事情而不需要 .Select 任何东西。如果找到匹配项，它也会提前跳出内部循环。

【讨论】：

【解决方案2】：

我认为这里有多个问题：

搜索方法的效率
Excel 失去响应性

如果可以将所有值放入数组中，则可以显着提高代码效率。这可以防止 VBA 在访问 Excel 对象模型和返回时花费时间。可以使用DoEvents 处理失去响应能力。试试下面的代码。它可能看起来很长，但应该很容易理解。

    'Find last row
    Dim lastRow As Variant
    lastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row

    'Create dynamic arrays
    Dim AT() As Variant: Dim AU() As Variant: Dim AV() As Variant
    ReDim AT(2 To lastRow): ReDim AU(2 To lastRow): ReDim AV(2 To lastRow)

    'Get all contents from Excel
    For i = 2 To lastRow
        AT(i) = Worksheets("Sheet1").Cells(i, 46)
        AU(i) = Worksheets("Sheet1").Cells(i, 47)
    Next i

    'Do the comparison
    For c = 2 To lastRow

        For d = 2 To lastRow
            If AT(c) = AU(d) Then AV(c) = AT(c)
        Next d

        'Allow a brief breather to Excel once in a while (don't hang)
        If (c / 100) = Int(c / 100) Then DoEvents

    Next c

    'Place final contents to Excel
    For i = 2 To lastRow
        Worksheets("Sheet1").Cells(i, 48) = AV(i)
    Next i

【讨论】：

【解决方案3】：

在你的循环中试试这个：

Dim StartRange As Range, j As Long
Dim CompareRange As Range, i As Range

With Worksheets("Sheet1")
    Set StartRange = .Range("AT1", .Range("AT:AT").Find("*", , , , xlByRows, xlPrevious))
    Set CompareRange = .Range("AU1", .Range("AU:AU").Find("*", , , , xlByRows, xlPrevious))

    For Each i In StartRange
        i.Offset(, -8).Value = .Evaluate("IF(COUNTIF(" & CompareRange.Address(0, 0) & "," & i.Address(0, 0) & ")>0," & i.Value & ","""")")
    Next i
End With

【讨论】：

【解决方案4】：

Dim CompareRange As Variant, To_Be_Compared As Variant, j As Variant, k As Variant

Range("AT2").Select
Selection.End(xlDown).Select
Set To_Be_Compared = Range("AT2:" & Selection.Address)
Range("AU2").Select
Selection.End(xlDown).Select
Set CompareRange = Range("AU2:" & Selection.Address)


To_Be_Compared.Select

    For Each j In Selection
        DoEvents
        For Each k In CompareRange
            If j = k Then j.Offset(0, 2) = j
        Next k
    Next j

【讨论】：

【解决方案5】：

我终于让它工作了，在接受建议并将它们实施到我的代码中之后，我能够看到错误的实际位置，我在代码的前面引用了错误的列，通过这个，没有创建重复的条目匹配，所以在修复这个之后，匹配现在出现了，我最终抵消了它们，并将值更改为“是”以反映我图表中的重复。

谢谢大家的帮助。

【讨论】：