VBA Array to compare and transfer if criteria met

JP 41 Reputation points
2021-02-25T10:01:07.437+00:00

Hi VBA experts,

Sorry I'm pretty new to VBA...

What i'm trying to achieve is that:
For each cell value of a column in the sheet "Dest", find the matching value in the sheet "Source".
If found, copy data from the row of that matching cell in "Source" and paste it in "Dest".
(in actuality, i have multiple conditions to meet)

Both sheets could have about 3000 rows. And my coding is simply taking far too long looping through both sheets and copy paste.
Is there a better/faster way of achieving this? Array??
Help please~~~

Thank you!
Jay

Below is what i came up with so far...


Option Compare Text
Sub B1_transfer_values_from_Source_to_Dest_table()

Dim x As Long
Dim y As Long
Dim LastRow1 As Long
Dim LastRow2 As Long

LastRow1 = ThisWorkbook.Worksheets("Source").Cells(Rows.Count, "A").End(xlUp).Row
LastRow2 = ThisWorkbook.Worksheets("Dest").Cells(Rows.Count, "A").End(xlUp).Row

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False

With Worksheets("Dest")

For y = LastRow2 To 2 Step -1
If .Cells(y, 1) = "" Then Rows(y).EntireRow.Delete
Next

' ** below takes too long **
For y = 2 To LastRow2
For x = 2 To LastRow1
If .Cells(y, 1) = Worksheets("Source").Cells(x, 1) Then
If .Cells(y, 4) = Worksheets("Source").Cells(x, 2) Then
If .Cells(y, 5) >= (Worksheets("Source").Cells(x, 4) - 0.004) Then
.Cells(y, 15) = Worksheets("Source").Cells(x, 4)
.Cells(y, 16) = Worksheets("Source").Cells(x, 5)
.Cells(y, 17) = Worksheets("Source").Cells(x, 6)
.Cells(y, 18) = Worksheets("Source").Cells(x, 7)
.Cells(y, 19) = Worksheets("Source").Cells(x, 8)
.Cells(y, 20) = Worksheets("Source").Cells(x, 9)
.Cells(y, 21) = Worksheets("Source").Cells(x, 10)

            .Cells(y, 22) = Worksheets("Source").Cells(x, 12)

            .Cells(y, 23) = Worksheets("Source").Cells(x, 15)
            .Cells(y, 24) = Worksheets("Source").Cells(x, 16)
            .Cells(y, 25) = Worksheets("Source").Cells(x, 17)

            End If
        End If
    End If
Next x

Next y

End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True

End Sub

{count} votes

Accepted answer
  1. Viorel 113.8K Reputation points
    2021-02-25T20:54:49.157+00:00

    A series of articles mentions that getting all values as an array increases the performance.

    To read the arrays of source and destination worksheets, try a code like this:

    Dim ws1 As Worksheet, ws2 As Worksheet
    
    Set ws1 = Worksheets("Source")
    Set ws2 = Worksheets("Dest")
    
    Dim r1 As Range, r2 As Range
    
    Set r1 = ws1.UsedRange
    Set r2 = ws2.UsedRange
    
    Dim d1, d2
    
    d1 = r1.Value
    d2 = r2.Value
    

    Here d1 and d2 represent bi-dimensional arrays (matrices) with source and destination values. Indices like d1(1,1), d1(1,2), d1(1,3), etc. is the first row, d1(2,1), d1(2,2), d1(2,3) etc. is the second row and so on.

    Note that d1 and d2 include the used range only, therefore d1(1,1) and d2(1,1) do not necessarily represent the A1 cell if the top or left area is empty.

    Also note that the sizes of d1 and d2 can be different.

    Using d1, d2 (and maybe ws1.UsedRange and ws2.UsedRange) variables you can make the corresponding loops. To change some destination value, use something like d2(y,19) = d1(x,8). Make sure that your code does not exceed the array bounds.

    Finally execute ws2.UsedRange.Value = d2 to update the destination worksheet.

    This seems to require some effort to implement, but it should work much faster.

    2 people found this answer helpful.
    0 comments No comments

2 additional answers

Sort by: Most helpful
  1. Nothing Left To Lose 396 Reputation points
    2021-02-25T18:04:39.613+00:00

    Re: comparing 1 column against another

    With each set of data having 3000 cells, you are making 9 million comparisons (3000 * 3000).
    That is why it takes so long.

    It would much quicker to 'Match' each cell in Dest against the entire column in Source...
    That would required only 3000 matches. (if there are no duplicates in Source)
    Something like...
    Application.WorksheetFunction.Match(.Cells(y, 1), Source.Column(1), 1, 0)

    '---
    NLtL
    https://1drv.ms/u/s!Au8Lyt79SOuhZ_2VvKCLZxz9iwI?e=vnEabM
    Add_Table of Contents, Calculate Payments, Custom_Functions, Professional_Compare

    1 person found this answer helpful.
    0 comments No comments

  2. JP 41 Reputation points
    2021-02-26T23:06:50.253+00:00

    Thank you so much, @Viorel !!!

    Following your suggestion, this is what I came up with (hope I got it right), and it indeed runs hundred times FASTER (only a few seconds instead of minutes) to loop through thousands of rows!
    Also it helped me understand better how arrays work too. :-D
    Thank you very much!

    Application.Calculation = xlCalculationManual  
    Application.ScreenUpdating = False  
    Application.DisplayStatusBar = False  
      
      
     Dim ws1 As Worksheet, ws2 As Worksheet  
          
     Set ws1 = Worksheets("Source")  
     Set ws2 = Worksheets("Dest")  
          
     Dim r1 As Range, r2 As Range  
          
     Set r1 = ws1.UsedRange  
     Set r2 = ws2.UsedRange  
          
     Dim d1, d2  
          
     d1 = r1.Value  
     d2 = r2.Value  
       
     For y = 2 To UBound(d2)  
        For x = 2 To UBound(d1)  
       
            If d2(y, 1) = d1(x, 1) Then   
                If d2(y, 4) = d1(x, 2) Then   
      
                    If d2(y, 5) >= (d1(x, 4) - 0.004) _  
                    And d2(y, 6) <= (d1(x, 4) + d1(x, 6) + 0.004) Then   
                    d2(y, 15) = d1(x, 4)  
                    d2(y, 16) = d1(x, 5)  
                    d2(y, 17) = d1(x, 6)  
                    d2(y, 18) = d1(x, 7)  
                    d2(y, 19) = d1(x, 8)  
                    d2(y, 20) = d1(x, 9)  
                    d2(y, 21) = d1(x, 10)  
                    d2(y, 22) = d1(x, 12)  
                    d2(y, 23) = d1(x, 15)  
                    d2(y, 24) = d1(x, 16)  
                    d2(y, 25) = d1(x, 17)  
                      
                    End If  
                End If  
            End If  
        Next x  
    Next y  
      
    ws2.UsedRange.Value = d2  
      
      
    Application.Calculation = xlCalculationAutomatic  
    Application.ScreenUpdating = True  
    Application.DisplayStatusBar = True  
    
    0 comments No comments