Skip a cycle for more than 100,000 rows of data on two sheets in one book

Question

I currently have code that allows me to view rows with a matching identifier from Sheet 1 and Sheet 2. When both IDs match, Sheet 2 information will be inserted into Sheet 1 rows with the same identifiers. My code runs on less than 1000 lines, and when I tested it gave results in a minute.

The problem is that when I tried to run it on 1,000,000 lines, it continues to work for more than 20 minutes and never stops working since then. I hope someone can help me make changes to the code so that I can loop through and copy the data 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 now.

Answer 1

Including @paulbica's suggestion, it ran a few 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 

Answer 2

You can use the index of the Dictionary object and use its own indexing properties to perform lokups. I’m not sure how well this will be performed in a data set of 200 thousand records, where a high failure report will occur, and you show at least 78% failure rate (200 thousand records for compliance and updating 43 thousand records )

 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 

As soon as both ranges are reflected in variant arrays, a dictionary is created to fully use its indexing properties for identification.

The above shows a significant increase in the efficiency of more than 200 thousand records in master compared to 43 thousand records in the tracker .

btw, for this I used .XLSB; not .XLSM.

Answer 3

It may also be faster to use 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 

This works with Office 2007. Office 2010 (I did not test in 2013) has a security measure that prevents updating Excel spreadsheets using SQL statements . In this case, you can use an old Jet provider that does not have this security measure. This provider does not support .xlsx , .xlsm or .xlsb ; only .xls .

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

Alternatively, you can read the data in a disabled recordset and insert the recordset into the original worksheet:

 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 

If you use CopyFromRecordset, keep in mind that there is no guarantee that the order will be returned, which may be a problem if the master table has data other than columns A and B. To solve this problem, you can include these other columns in set of records. In addition, you can force the order of records using the ORDER BY and sort the data on the sheet before starting work.