VBA Array to compare and transfer if criteria met

Question

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

Answer 1

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.

Answer 2

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

Answer 3

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