Esegui un ciclo per più di 100.000 righe di dati in due fogli nella stessa cartella di lavoro

Question

Attualmente ho il codice che mi consente di esaminare le righe con ID corrispondente dal Foglio 1 e dal Foglio 2. Quando entrambi gli ID corrispondono, Foglio 2 le informazioni verranno incollate alle righe del Foglio 1 con gli stessi ID. Il mio codice funziona su meno di 1.000 righe e quando ho provato ha dato risultati entro un minuto.

Il problema è che quando ho provato a eseguirlo per 1.000.000 di righe, continua a funzionare e per più di 20 minuti e non smette mai di funzionare da allora. Spero che qualcuno possa aiutarmi a modificare il codice per consentirmi di eseguire un ciclo e copiare le informazioni dal Foglio 2 al Foglio 1 per 200.000 righe.

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 

Sopra è il codice che ho per ora.

Answer 1

Incorporando il suggerimento di @ paulbica, questo è durato diversi secondi per 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

è possibile utilizzare l'indice di un Dictionary object e utilizzare le sue proprietà di indicizzazione native per eseguire le lokups. Non sono sicuro di quanto bene si produrrà in un set di dati di record di 200K in cui si verificherà un elevato rapporto di errore e si sta visualizzando almeno un tasso di errore del 78% (record di 200.000 per abbinare e aggiornare i record 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 

volta entrambi gli intervalli sono speculari in array variante, il dizionario viene creato per utilizzare pienamente le sue proprietà di indicizzazione per l'identificazione.

Gli spettacoli di cui sopra su un significativo incremento di efficienza oltre 200K record in maestro vs 43K record in inseguitore.

btw, ho usato un .XLSB per questo; non un .XLSM.

Answer 3

Potrebbe anche essere più veloce utilizzare 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 

Questo funziona con Office 2007. Office 2010 (non ho ancora testato su 2013) ha un security measure that prevents updating Excel spreadsheets with an SQL statement. In questo caso è possibile utilizzare il vecchio provider Jet, che non dispone di questa misura di sicurezza. Questo provider non supporta i file .xlsx, .xlsm o .xlsb; solo .xls.

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

In alternativa, è possibile leggere i dati risultanti in un recordset disconnesso e incollare il set di record nel foglio originale:

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 

Se si utilizza CopyFromRecordset, tenere a mente che non v'è alcuna garanzia dell'ordine in cui vengono restituiti i record, il che potrebbe essere un problema se nel foglio di lavoro master sono presenti altri dati oltre alle colonne A e B. Per risolvere questo problema, è possibile includere anche quelle altre colonne nel recordset. In alternativa, è possibile applicare l'ordine dei record utilizzando una clausola ORDER BY e ordinare i dati nel foglio di lavoro prima di iniziare.