在同一个工作簿的两个工作表中运行超过 100,000 行数据的循环

Question

我目前有代码可以让我查看工作表 1 和工作表 2 中具有匹配 ID 的行。当两个 ID 匹配时，工作表 2 信息将粘贴到具有相同 ID 的工作表 1 行。我的代码在不到 1,000 行上工作，当我测试它时，它在一分钟内给出了结果。

问题是，当我尝试运行它 1,000,000 行时，它会继续运行超过 20 分钟，并且从那时起就再也没有停止运行。我希望任何人都可以帮助我更改代码以允许我执行循环并将信息从表 2 复制粘贴到表 1 中 200,000 行。

Sub Sample()


  Dim tracker As Worksheet
    Dim master As Worksheet
    Dim cell As Range
    Dim cellFound As Range
    Dim OutPut As Long

   Set tracker = Workbooks("test.xlsm").Sheets("Sheet1")
   Set master = Workbooks("test.xlsm").Sheets("Sheet2")

   Application.ScreenUpdating = False
    For Each cell In master.Range("A2:A200000")

        Set cellFound = tracker.Range("A5:A43000").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not cellFound Is Nothing Then
      matching value

            cellFound.Offset(ColumnOffset:=1).Value2 = cell.Offset(ColumnOffset:=2).Value2


        Else

        End If
        Set cellFound = Nothing
        Debug.Print cell.Address
    Next
    Application.ScreenUpdating = True
    OutPut = MsgBox("Update over!", vbOKOnly, "Update Status")


End Sub

以上是我现在拥有的代码。

Answer 1

结合@paulbica 的建议，这对我来说只需几秒钟。

Sub Sample()

    Dim rngTracker As Range
    Dim rngMaster As Range
    Dim arrT, arrM
    Dim dict As Object, r As Long, tmp

    With Workbooks("test.xlsm")
        Set rngTracker = .Sheets("Tracker").Range("A2:B43000")
        Set rngMaster = .Sheets("Master").Range("A2:C200000")
    End With

    'get values in arrays
    arrT = rngTracker.Value
    arrM = rngMaster.Value

    'load the dictionary
    Set dict = CreateObject("scripting.dictionary")
    For r = 1 To UBound(arrT, 1)
        dict(arrT(r, 1)) = r
    Next r

    'map between the two arrays using the dictionary
    For r = 1 To UBound(arrM, 1)
        tmp = arrM(r, 1)
        If dict.exists(tmp) Then
            arrT(dict(tmp), 2) = arrM(r, 3)
        End If
    Next r

    rngTracker.Value = arrT

End Sub

Answer 2

您可以使用Dictionary object 的索引并使用其本机索引属性来执行查找。我不确定它在 200K 记录的数据集中表现如何，其中将发生高故障报告并且您显示至少 78% 的故障率（200K 记录匹配和更新 43K 记录）。

Sub Sample3()
    Dim tracker As Worksheet, master As Worksheet
    Dim OutPut As Long
    Dim v As Long, p As Long, vMASTER As Variant, vTRACKER As Variant, dMASTER As Object

    Set tracker = Workbooks("test.xlsm").Sheets("Sheet1")
    Set master = Workbooks("test.xlsm").Sheets("Sheet2")
    Set dMASTER = CreateObject("Scripting.Dictionary")

    Debug.Print Timer
    'Application.ScreenUpdating = False '<~~no real need to do this if working in memory

    With tracker
        vTRACKER = .Range(.Cells(5, 2), .Cells(Rows.Count, 1).End(xlUp)).Value2
    End With

    With master
        vMASTER = .Range(.Cells(2, 1), .Cells(Rows.Count, 3).End(xlUp)).Value2
        For v = LBound(vMASTER, 1) To UBound(vMASTER, 1)
            If Not dMASTER.exists(vMASTER(v, 1)) Then _
                dMASTER.Add Key:=vMASTER(v, 1), Item:=vMASTER(v, 3)
        Next v
    End With

    For v = LBound(vTRACKER, 1) To UBound(vTRACKER, 1)
        If dMASTER.exists(vTRACKER(v, 1)) Then _
            vTRACKER(v, 2) = dMASTER.Item(vTRACKER(v, 1))
    Next v

    With ThisWorkbook.Sheets("Sheet1")  'tracker
        .Cells(5, 1).Resize(UBound(vTRACKER, 1), 2) = vTRACKER
    End With

    'Application.ScreenUpdating = True '<~~no real need to do this if working in memory
    Debug.Print Timer
    OutPut = MsgBox("Update over!", vbOKOnly, "Update Status")

    dMASTER.RemoveAll: Set dMASTER = Nothing
    Set tracker = Nothing
    Set master = Nothing

End Sub

一旦将两个范围镜像到变体数组中，就会创建一个字典，以便充分利用其索引属性进行识别。

上面显示了 ma​​ster 中超过 200K 记录的效率显着提高，而 tracker 中的记录为 43K。

顺便说一句，我确实为此使用了 .XLSB；不是 .XLSM。

Answer 3

使用 ADODB 也可能更快。

Dim filepath As String
Dim conn As New ADODB.Connection
Dim sql As String

filepath = "c:\path\to\excel\file\book.xlsx"

With conn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=""" & filepath & """;" & _
        "Extended Properties=""Excel 12.0;HDR=No"""

    sql = _
        "UPDATE [Sheet1$A2:B200000] AS master " & _
        "INNER JOIN [Sheet2$] AS tracker ON master.F1 = tracker.F1 " & _
        "SET master.F2 = tracker.F2"
    .Execute sql
End With

这适用于 Office 2007。Office 2010（我没有在 2013 上测试过）有一个 security measure that prevents updating Excel spreadsheets with an SQL statement。在这种情况下，您可以使用没有此安全措施的旧 Jet 提供程序。此提供程序不支持.xlsx、.xlsm 或.xlsb 文件；只有.xls。

With conn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Data Source=""" & filepath & """;" & _
        "Extended Properties=""Excel 8.0;HDR=No"""

或者，您可以将结果数据读入断开连接的记录集，然后将记录集粘贴到原始工作表中：

Dim filepath As String
Dim conn As New ADODB.Connection
Dim sql As String
Dim rs As New ADODB.Recordset

filepath = "c:\path\to\excel\file\book.xlsx"

With conn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=""" & filepath & """;" & _
        "Extended Properties=""Excel 12.0;HDR=No"""

    sql = _
        "SELECT master.F1, IIF(tracker.F1 Is Not Null, tracker.F2, master.F2) " & _
        "FROM [Sheet1$A2:B200000] AS master " & _
        "LEFT JOIN [Sheet2$] AS tracker ON master.F1 = tracker.F1 "

    rs.CursorLocation = adUseClient
    rs.Open sql, conn, adOpenForwardOnly, adLockReadOnly
    conn.Close
End With

Workbooks.Open(filepath).Sheets("Sheet1").Cells(2, 1).CopyFromRecordset rs

如果使用 CopyFromRecordset，请记住不能保证返回记录的顺序，如果 master 工作表中除了 A 和 B 列之外还有其他数据，这可能会出现问题。要解决此问题，您也可以在记录集中包含这些其他列。或者，您可以使用 ORDER BY 子句强制记录的顺序，并在开始之前对工作表中的数据进行排序。