Esiste un modo più rapido per confrontare i dati tra gli array dinamici in VBA?

Question

Ho il codice seguente che funziona correttamente, tuttavia deve essere eseguito su due array di 130k + righe ciascuno. Il tempo di esecuzione corrente sull'intero set di dati è di circa 24 minuti e dopo aver aggiunto un conteggio a un certo punto, il ciclo si avvicina a 9,8 miliardi di volte.

Ho letto gli articoli sull'utilizzo di Match, Vlookup e sembrano suggerire che un ciclo iterativo (come ho usato) è il metodo più veloce, tuttavia non sono riuscito a capire come far funzionare gli altri metodi con array dinamici e quindi testare in modo appropriato.

Qualcuno è in grado di dirmi se esiste un modo più rapido per completare questa attività e, in tal caso, dimostrare come?

Sub TESTVLOOKUPARRAY() 
    Dim PSORG1() As Variant 
    Dim PSORG1Tot As Variant 
    Dim PSORG1RT As Variant 
    Dim PSORG2() As Variant 
    Dim PSORG2Tot As Variant 
    Dim PSORG2RT As Variant 

    Sheets("Sheet1").Select 
    PSORG2RT = Application.CountA(Range("A:A")) 
    PSORG2Tot = "A1:B" & PSORG2RT 
    PSORG2 = Range(PSORG2Tot) ' PSORG2 is now an allocated array 

    Sheets("Sheet2").Select 
    PSORG1RT = Application.CountA(Range("A:A")) 
    PSORG1Tot = "A1:B" & PSORG1RT 
    PSORG1 = Range(PSORG1Tot) ' PSORG1 is now an allocated array 

    a = 2 ' to increment ORG values in PSORG1 

    Do 
     Finish = "No" 
     b = 1 ' to increment ORG values in PSORG2 
     Do 
      If PSORG1(a, 1) = PSORG2(b, 1) Then 
       PSORG1(a, 2) = PSORG2(b, 2) 
       Finish = "True" 
      ElseIf b = PSORG2RT Then 
       PSORG1(a, 2) = "NULL" 
       Finish = "True" 
      End If 
      b = b + 1 
     Loop Until Finish = "True" 
     a = a + 1 
    Loop Until a = PSORG1RT + 1 

    Sheets("Sheet2").Select 
    Set Destination = Range("A1") 
    Destination.Resize(UBound(PSORG1, 1), UBound(PSORG1, 2)).Value = PSORG1 

End Sub 

Answer 1

Sono d'accordo con il metodo Scripting.Dictionary.

Questa procedura utilizza Scripting.Dictionsry. È necessario accedere a Strumenti ► Riferimenti di VBE e aggiungere un riferimento a Microsoft Scripting Runtime.

Sub TESTVLOOKUPARRAY() 
    Dim PSORG1 As Variant, PSORG2 As Variant 
    Dim a As Long, b As Long 
    Dim dPSORG2 As New Scripting.dictionary 

    dPSORG2.CompareMode = TextCompare 

    Debug.Print Timer 

    With Sheets("Sheet1") 
     a = .Cells(Rows.Count, 1).End(xlUp).Row 
     PSORG2 = .Cells(1, 1).Resize(a, 2).Value2 ' PSORG2 is now an allocated array 
     For b = LBound(PSORG2, 1) To UBound(PSORG2, 1) 
      dPSORG2.Item(PSORG2(b, 1)) = PSORG2(b, 2) 
     Next b 
    End With 

    With Sheets("Sheet2") 
     a = .Cells(Rows.Count, 1).End(xlUp).Row 
     PSORG1 = .Cells(1, 1).Resize(a, 2).Value2 ' PSORG1 is now an allocated array 
    End With 

    Debug.Print dPSORG2.Count 
    Debug.Print LBound(PSORG2, 1) & ":" & UBound(PSORG2, 1) 
    Debug.Print LBound(PSORG2, 2) & ":" & UBound(PSORG2, 2) 
    Debug.Print LBound(PSORG1, 1) & ":" & UBound(PSORG1, 1) 
    Debug.Print LBound(PSORG1, 2) & ":" & UBound(PSORG1, 2) 

    For b = LBound(PSORG1, 1) To UBound(PSORG1, 1) 
     If dPSORG2.Exists(PSORG1(b, 1)) Then 
      PSORG1(b, 2) = dPSORG2.Item(PSORG1(b, 1)) 
     Else 
      PSORG1(b, 2) = "NULL" 
     End If 
    Next b 


    With Sheets("Sheet2") 
     .Cells(1, 1).Resize(UBound(PSORG1, 1), UBound(PSORG1, 2)) = PSORG1 
    End With 

    Debug.Print Timer 

End Sub 

FWIW, i miei dati di esempio di 110K righe di Sheet1 e 95K righe in Sheet2 corse in 20 minuti, 40 secondi con il codice originale. Quanto sopra ha richiesto 1.72 secondi sugli stessi dati.

Answer 2

Penso che usare i dizionari renderebbe il codice più veloce.

Di seguito è riportato il codice che esegue la stessa operazione ma utilizza oggetto dizionario. Sul mio computer è circa 100 volte più veloce del tuo codice (testato su due fogli di lavoro con 5K righe ciascuno, per i set di dati più grandi il guadagno dovrebbe essere ancora migliore).

Public Function TestVLookupArray2() 
    Dim dict As Object 
    Dim result As Variant 
    Dim i As Long 
    Dim destination As Excel.Range 


    'Load values from Sheet1 into Dictionary. 
    Set dict = getDataFromSheetAsDictionary(Sheets("Sheet1")) 

    result = getDataFromSheet(Sheets("Sheet2")) 

    For i = LBound(result, 1) To UBound(result, 1) 

     With dict 
      If .exists(result(i, 1)) Then 
       result(i, 2) = .Item(result(i, 1)) 
      Else 
       result(i, 2) = "NULL" 
      End If 
     End With 

    Next i 

    With Sheets("Sheet2") 
     Set destination = .Range(.Cells(1, 1), .Cells(UBound(result, 1), UBound(result, 2))) 
     destination = result 
    End With 

End Function 


Private Function getDataFromSheet(wks As Excel.Worksheet) As Variant 
    Dim lastRow As Long 

    With wks 
     lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 
     getDataFromSheet = .Range(.Cells(1, 1), .Cells(lastRow, 2)) 
    End With 

End Function 


Private Function getDataFromSheetAsDictionary(wks As Excel.Worksheet) As Object 
    Dim i As Long 
    Dim key As String 
    Dim value As Variant 
    Dim arr As Variant 

    Set getDataFromSheetAsDictionary = VBA.CreateObject("Scripting.Dictionary") 

    arr = getDataFromSheet(wks) 

    With getDataFromSheetAsDictionary 
     For i = LBound(arr, 1) To UBound(arr, 1) 

      If Not .exists(arr(i, 1)) Then 
       Call .Add(arr(i, 1), arr(i, 2)) 
      End If 

     Next i 
    End With 

End Function 

Si noti che questo codice è composto da 3 funzioni separate, è necessario includerle tutte.

Ecco l'articolo che introduce al Dizionari: http://www.techbookreport.com/tutorials/vba_dictionary.html

Per eventuali domande a questo codice, fatemelo sapere nei commenti.

Answer 3

ho usato un ciclo for next, come una posa alla do ciclo usato da voi.

Sub speed_up2() 
    Dim PSORG1() As Variant, PSORG2() As Variant 
    Dim PSORG1Tot As Range, PSORG2Tot As Range, Destination As Range 
    Dim PSORG1RT As Long, PSORG2RT As Long 
    Dim wb As Workbook, ws_1 As Worksheet, ws_2 As Worksheet 
    Dim i As Byte, j As Byte 

    Set wb = ThisWorkbook 
    Set ws_1 = wb.Sheets("Sheet1") 
    Set ws_2 = wb.Sheets("Sheet2") 

    with ws_1 
     PSORG2RT = .Cells(Rows.Count, 1).End(xlUp).Row ' Get last row 
     Set PSORG2Tot = .Range("A1:B" & PSORG2RT) 
     PSORG2 = PSORG2Tot ' PSORG2 is now an allocated array 
    End With 

    With ws_2 
     PSORG1RT = .Cells(Rows.Count, 1).End(xlUp).Row 
     Set PSORG1Tot = .Range("A1:B" & PSORG1RT) 
     PSORG1 = PSORG1Tot ' PSORG1 is now an allocated array 
    End With 

    For i = 1 To UBound(PSORG1) 
     For j = 1 To UBound(PSORG2) 
      PSORG1(i, 2) = "NULL" 
      If PSORG1(i, 1) = PSORG2(j, 1) Then 
       PSORG1(i, 2) = PSORG2(j, 2) 
       Exit For 
      End If 
     Next j 
    Next i 

    Set Destination = ws_2.Range("A1") 
    Destination.Resize(UBound(PSORG1, 1), UBound(PSORG1, 2)).Value = PSORG1 
End Sub 

Vedere here per uno speedtest che è stata eseguita tra il for next ciclo e il ciclo do.

Come specificato nell'articolo, il ciclo for next sta eseguendo il calcolo dell'iterazione successiva per voi, mentre con il ciclo do è necessario incrementare ogni volta l'iterazione. Questo può far risparmiare un sacco di tempo.

Ho anche modificato il metodo per ottenere l'ultima riga, utilizzata per creare l'intervallo. Questa è la mia preferenza personale; potrebbe anche essere più sicuro da utilizzare rispetto a Application.COUNTA.