The loop over two arrays take LONG

Question

Thanks for your helps, I have two arrays: A (100k row, 10 col) and B (100k row, 12 col)

The following code (thanks to BSALV) loop through A and B => It takes really long to finish. Is there any way to speedup.

ReDim Preserve B(1 To UBound(B), 1 To UBound(B, 2) + 4)
     ReDim arr(1 To UBound(B), 1 To 2)
     For i = 1 To UBound(B)
          
          iSell = B(i, 3): mysold = 0

          r = Application.Match(B(i, 2), Application.Index(A, 0, 2), 0)   
          If IsNumeric(r) Then                                  
               For i1 = r To UBound(A)                       
                    If A(i1, 2) = B(i, 2) And A(i1, 1) <= B(i, 1) Then 
                         x = Application.Max(0, Application.Min(A(i1, 3), iSell))
                         If x > 0 Then
                              mysold = mysold + x
                              iSell = iSell - x                
                              MyValueSold = MyValueSold + x * A(i1, 4)     
                              A(i1, 3) = A(i1, 3) - x     
                              If A(i1, 3) <= 0 Then A(i1, 2) = "~"     
                         End If
                         
                         If A(i1, 3) > 0 Then Exit For                       
                    End If
               Next
          End If
          arr(i, 1) = mysold: arr(i, 2) = MyValueSold 
     Next

Answer 1

This operation is really slow when using larger arrays:

r = Application.Match(B(i, 2), Application.Index(A, 0, 2), 0)

You can get much better performance just by replacing the Index/Match line with a dictionary lookup.

To illustrate:

Sub Tester()

    Const NROWS As Long = 100000
    Dim i As Long, r, t
    Dim dict As Object
    Set dict = CreateObject("scripting.dictionary")
    Dim A(1 To NROWS, 1 To 10)
    
    'populate some dummy data
    For i = 1 To UBound(A, 1)
        A(i, 2) = Application.RandBetween(1, NROWS)
        A(i, 3) = i
    Next i
    
    'First your existing row lookup...
    t = Timer
    For i = 1 To 100 'only testing 100 lookups (too slow for more!)
        r = Application.Match(i, Application.Index(A, 0, 2), 0)
    Next i
    Debug.Print "Index/Match lookup", Timer - t, "*100* lookups"
    
    'populate a dictionary for lookups...
    t = Timer
    For i = 1 To NROWS
        dict(A(i, 2)) = i 'mapping second column first occurences to row #
    Next i
    Debug.Print "Mapping done", Timer - t
    
    'Now the dictionary lookup
    t = Timer
    For i = 1 To NROWS
        If dict.Exists(i) Then
            r = dict(i)
        End If
    Next i
    Debug.Print "Dictionary lookup", Timer - t, NROWS & " lookups"
End Sub

Output:

Index/Match lookup           9.62     *100* lookups  '<<< slow slow!
Mapping done                 0.12 
Dictionary lookup            0.26     100000 lookups

EDIT: changes in your existing code

Dim rngMatch As Range  '<<< added
'...
'...
Set lo = Sheets("Exc").ListObjects("TBL_Buy")
Set rngMatch = lo.DataBodyRange.Columns(2)    '<<< lookup range
With lo.Range
    .Sort .Range("B1"), xlAscending, , .Range("A1"), xlAscending, Header:=xlYes
    aBuy = lo.DataBodyRange.Value2
    .Sort .Range("A1"), xlAscending, , .Range("B1"), xlAscending, Header:=xlYes
End With
'...
For i = 1 To UBound(aResult)
    '...
    r = Application.Match(aResult(i, 2), rngMatch, 0) '<<<
    '...
    '...