加快匹配值处理（如果 ... = ... 那么 ...）

Question

所以我目前的代码如下所示：我基本上是在尝试检查是否可以在另一张表的 C 列中找到一张表的 B 列，然后我会在另一张表的行中找到 B 值，取其 H 列值并将其复制到当前工作表的 AI 列。对于 B 列中的每一行都会重复此过程。

我遇到的问题是它的运行速度太慢了，即使关闭了屏幕更新等。这是有道理的，因为它必须循环遍历超过 50000 个值以及它必须查找的所有值。如果有人能够仔细研究并提出可以加快进程的潜在方法，我将不胜感激。谢谢。

Sub Calculation()

  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Application.DisplayStatusBar = False
  Application.EnableEvents = False
  ActiveSheet.DisplayPageBreaks = False

  Dim i As Long, LastRow As Long
  LastRow = Range("A" & Rows.Count).End(xlUp).Row

  For i = 5 To LastRow

  Set wb1 = ThisWorkbook
  Dim anyRow As Long

    For anyRow = 4 To 500
      If wb1.Sheets("Total").Cells(anyRow, 2).Value =                    wb1.Sheets("Record").Cells(i, 3).Value Then
        wb1.Sheets("Record").Cells(i, 35).Value =     wb1.Sheets("Total").Cells(anyRow, 8).Value
      End If
    Next anyRow
  Next i

  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.DisplayStatusBar = True
  Application.EnableEvents = True
  ActiveSheet.DisplayPageBreaks = True

End Sub

Answer 1

使用字典将允许您仅对每个工作表进行 1 次迭代。字典将信息存储在 {Key, Value} 对中。键是唯一的，用作查找关联的值。

这里我们将 Sheets("Total") 中的 {Key, Value} 对添加到字典中

k = .Cells(i, 2).Text
v = .Cells(i, 2)
If Not dictTotals.Exists(k) Then dictTotals.Exists.Add k, v

现在当我们迭代 Sheets("Record") 时，我们检查是否有匹配项。如果是这样，我们将键的值分配给 .Cells(i, 35).Value。

k = .Cells(i, 3).Text
If dictTotals.Exists(k) Then .Cells(i, 35).Value = dictTotals(k)

我推断此方法来处理切换事件。这样，我们就可以专注于 Calculation() 方法的主要任务。

Sub Calculation()
    EnableAllEvents True
    Dim i As Long, LastRow As Long
    Dim dictTotals
    Dim k As String, v As Variant
    Set dictTotals = CreateObject("Scripting.Dictionary")

    LastRow = Range("A" & Rows.Count).End(xlUp).Row

    With Sheets("Total")
        For i = 5 To LastRow
            k = .Cells(i, 2).Text
            v = .Cells(i, 2)
            If Not dictTotals.Exists(k) Then dictTotals.Exists.Add k, v
        Next
    End With

    With Sheets("Record")
        LastRow = Range("c" & Rows.Count).End(xlUp).Row

        For i = 4 To LastRow
            k = .Cells(i, 3).Text
            If dictTotals.Exists(k) Then .Cells(i, 35).Value = dictTotals(k)
        Next
    End With

    EnableAllEvents False
End Sub


Sub EnableAllEvents(bEnableEvents As Boolean)
    With Application
        If bEnableEvents Then .Calculation = xlCalculationAutomatic Else .Calculation = xlCalculationManual
        .ScreenUpdating = bEnableEvents
        .DisplayStatusBar = bEnableEvents
        .EnableEvents = bEnableEvents
        .DisplayPageBreaks = bEnableEvents
    End With
End Sub

Answer 2

这应该做你想做的事（快得多）：

Sub Calculation()
  With ThisWorkbook
    Dim i As Long, LastRow As Long
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Dim rngVal(3) As Variant
    rngVal(0) = .Sheets("Total").Range("B4:B500").Value
    rngVal(1) = .Sheets("Record").Range("C5:C" & LastRow).Value
    rngVal(2) = .Sheets("Record").Range("AI5:AI" & LastRow).Value
    rngVal(3) = .Sheets("Total").Range("H4:H500").Value
    For i = 1 To LastRow - 4
      If IsNumeric(Application.Match(rngVal(1)(i, 1), rngVal(0), 0)) Then rngVal(2)(i, 1) = rngVal(3)(Application.Match(rngVal(1)(i, 1), rngVal(0), 0), 1)
    Next
    .Sheets("Record").Range("AI5:AI" & LastRow).Value = rngVal(2)
  End With
End Sub