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

So I currently have code which looks like this: I'm basically trying to check that if one sheet's column B can be found in another sheet's column C, then I will, in that other sheet's row where I found the B value, take its H column value and copy it to the current sheet's AI column. This process will be repeated for every row in the B column.

所以我目前的代码看起来像这样:我基本上试图检查如果一张纸的列B可以在另一张纸的列C中找到,那么我会在另一张纸的行中找到B值,取其H列值并将其复制到当前工作表的AI列。将对B列中的每一行重复此过程。

The problem I'm encountering is that it's running way too slow, even with turning off screenupdates etc. This makes sense because there are over 50000 values it has to loop through along with all the values it has to lookup. I would really appreciate it if someone could look it through and come up with potential ways i could speed up the process. Thank you.

我遇到的问题是它运行方式太慢,即使关闭了屏幕更新等。这是有道理的,因为它必须循环超过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

2 个解决方案

#1

This should do what you want (a lot faster):

这应该做你想要的(更快):

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

#2

Using a dictionary will allow you to iterate each sheet just 1 time. A dictionary stores information in {Key, Value} pairs. Keys are unique and used as lookup the associated Value.

使用字典将允许您只迭代每张表一次。字典以{Key,Value}对存储信息。密钥是唯一的,用于查找关联的值。

Here we are adding {Key, Value} pairs from Sheets("Total") to the dictionary

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

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

Now as we iterate Sheets("Record"), we check to see if we have a matching. If so we assign the Key's Values to .Cells(i, 35).Value.

现在,当我们迭代表格(“记录”)时,我们检查是否有匹配。如果是这样,我们将Key的值分配给.Cells(i,35).Value。

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

I extrapolated this method to handle toggling events. In this way, we can focus on the Calculation() methods main task.

我推断这个方法来处理切换事件。通过这种方式,我们可以专注于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

#1