在同一工作簿中的两张表中运行超过100,000行数据的循环 [英] Run through a loop for more than 100,000 rows of data in two sheets in the same workbook

问题描述

我目前有代码允许我从Sheet 1和Sheet 2中查找匹配ID的行。当两个ID匹配时，Sheet 2信息将被粘贴到具有相同ID的Sheet 1行。我的代码工作在少于1,000行，当我测试它在一分钟内给出结果。

问题是，当我尝试运行它1,000,000行时，它会持续运行20分钟以上，从此不再停止运行。我希望任何人都可以协助我修改代码，让我做一个循环，并将信息从Sheet 2复制粘贴到Sheet 1上20万行。

  Sub Sample（）
 
 
 Dim tracker As Worksheet 
 Dim master As Worksheet 
 Dim cell As Range 
 Dim cellFound作为范围
 Dim OutPut As Long 
 
设置tracker =工作簿（test.xlsm）。Sheets（Sheet1）
设置master = Workbooks（test.xlsm ）.Sheets（Sheet2）
 
 Application.ScreenUpdating = False 
对于每个单元格在master.Range（A2：A200000）
 
设置cellFound = tracker.Range（A5：A43000）。Find（What：= cell.Value，LookIn：= xlValues，LookAt：= xlWhole）
如果不是cellFound不是然后
匹配值
 
 cellFound.Offset（ColumnOffset：= 1）.Value2 = cell.Offset（ColumnOffset：= 2）.Value2 
 
 
 Else 
 
结束If 
设置cellFound = Nothing 
 Debug.P rint cell.Address 
下一个
 Application.ScreenUpdating = True 
 OutPut = MsgBox（Update over！，vbOKOnly，Update Status）
 
 
 End Sub 
  

以上是我现在的代码。

解决方案

纳入@ paulbica的建议，这对我来说几秒钟。

  Sub Sample（）
 
 Dim rngTracker As Range 
 Dim rngMaster As Range 
 Dim arrT，arrM 
 Dim dict As Object，r As Long，tmp 
 
使用工作簿（test.xlsm）
设置rngTracker = .Sheets（Tracker）。范围（A2：B43000）
设置rngMaster = .Sheets Master）。Range（A2：C200000）
 End with 
 
'获取数组中的值
 arrT = rngTracker.Value 
 arrM = rngMaster.Value 
 
'加载字典
 Set dict = CreateObject（scripting.dictionary）
对于r = 1 To UBound（arrT，1）
 dict（a rrT（r，1））= r 
下一个r 
 
'使用字典的两个数组之间的映射
对于r = 1 To UBound（arrM，1）
 tmp = arrM（r，1）
如果dict.exists（tmp）然后
 arrT（dict（tmp），2）= arrM（r，3）
 End If 
下一步r 
 
 rngTracker.Value = arrT 
 
 End Sub 
  

I currently have code to allow me to look through the rows with matching ID from Sheet 1 and Sheet 2. When both IDs match, Sheet 2 information will be pasted to the Sheet 1 rows with the same IDs. My code works on less than 1,000 rows and when I tested it gave results within a minute.

The problem is that when I tried to run it for 1,000,000 rows it keeps running and for more than 20 minutes and never stop running since then. I hope anyone could assist me in making changes to the code to allow me to do a loop and copy paste the information from Sheet 2 to Sheet 1 for 200,000 rows.

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

Above is the code that I have for now.

解决方案

Incorporating @paulbica's suggestion, this ran in several seconds for me.

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

这篇关于在同一工作簿中的两张表中运行超过100,000行数据的循环的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！