Match and copy optimization (slow)

[Miro H]

Hello, I have a VBA code that compares values in key column on worksheet 1 with one by one value in key column in worksheet 2 (column header selected by user). When (and if) the key values on worksheet 2 match with value in key column on worksheet 1 than it copies several columns from worksheet 2 to worksheet 1 (column headers in range that has to be copied is also selected by user).
It is like VLOOKUP but more cells are copied.
Both worksheets have the same number and distribution of columns but different number of rows.

I have some 3000 rows in both sheets and it takes couple of minutes for code to finish. I suppose matching and copying could be optimized. This is the vital part of the code:

For i = 1 To nrs1 - 1
    j = 1
    Do While j < nrs2
        If Worksheets(1).Range(addr1).Offset(i, 0).Value = Worksheets(2).Range(addr1).Offset(j, 0).Value Then
            Worksheets(1).Range(addr2).Offset(i, 0).Value = Worksheets(2).Range(addr2).Offset(j, 0).Value
            Exit Do
        End If
        j = j + 1
    Loop
Next i

How could I optimize this part of the code?


Here is the complete code:

Sub MatchAndCopy()
Dim nrs1 As Integer, nrs2 As Integer, i As Integer, j As Integer
Dim rng1 As Range, rng2 As Range, addr1 As String, addr2 As String
Set rng1 = Application.InputBox("Select column for match", , , , , , , 8)
addr1 = rng1.Address
Set rng2 = Application.InputBox("Select columns for copy", , , , , , , 8)
addr2 = rng2.Address
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Worksheets(1).Select
Range("A1").Select
nrs1 = Selection.CurrentRegion.Rows.Count
Worksheets(2).Select
Range("A1").Select
nrs2 = Selection.CurrentRegion.Rows.Count
For i = 1 To nrs1 - 1
    j = 1
    Do While j < nrs2
        If Worksheets(1).Range(addr1).Offset(i, 0).Value = Worksheets(2).Range(addr1).Offset(j, 0).Value Then
            Worksheets(1).Range(addr2).Offset(i, 0).Value = Worksheets(2).Range(addr2).Offset(j, 0).Value
            Exit Do
        End If
        j = j + 1
    Loop
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

 

[igold]

Does this come close to doing what you want, (I would have liked to have seen your data).

Sub MatchAndCopy()

    Dim arr1, arr2, arr3
    Dim nrs1 As Long, nrs2 As Long, i As Long, nr As Long, ColumnNumber As Long
    Dim rng1 As Range, rng2 As Range, addr1 As String, addr2 As String
    Dim str1 As String, str2 As String, ColumnLetter As String

    Set rng1 = Application.InputBox("Select column for match", , , , , , , 8)
    addr1 = rng1.Address(False, False)
    Set rng2 = Application.InputBox("Select columns for copy", , , , , , , 8)
    addr2 = rng2.Address(False, False)
    
    Application.ScreenUpdating = False
    
    Worksheets(1).Select
    Range("A1").Select
    arr1 = Range(addr2, Range("A" & Rows.Count).End(xlUp)).Value2
    nrs1 = Selection.CurrentRegion.Rows.Count
    Worksheets(2).Select
    Range("A1").Select
    nrs2 = Selection.CurrentRegion.Rows.Count
    arr2 = Range(addr2, Range("A" & Rows.Count).End(xlUp)).Value2
    
    ColumnLetter = addr1
    ColumnNumber = Range(ColumnLetter & 1).Column
    nr = UBound(arr2, 2)
    arr3 = arr1
    
    For i = 1 To UBound(arr1)
        arr3(i, nr) = arr1(i, nr)
        If arr1(i, ColumnNumber) = arr2(i, ColumnNumber) Then
            arr3(i, nr) = arr2(i, nr)
        End If
    Next
    Worksheets("Sheet1").Range("A1").Resize(UBound(arr3, 1), UBound(arr3, 2)) = arr3
    
    Application.ScreenUpdating = True
    MsgBox "Operation Complete"
    
End Sub

 

[Miro H]

Hello, thanks for the answer.

I get an error when I run your code in this line:
Worksheets("Sheet1").Range("A1").Resize(UBound(arr3, 1), UBound(arr3, 2)) = arr3


I'm trying to understand what did you do.

arr1 - complete table on sheet 1
arr2 - complete table on sheet 2

 nr = UBound(arr2, 2) 'this is the total number of columns in arr2
    arr3 = arr1 
    
    For i = 1 To UBound(arr1) 'go through all rows of arr1
        arr3(i, nr) = arr1(i, nr) ' last column of arr3 = last column of arr1
        If arr1(i, ColumnNumber) = arr2(i, ColumnNumber) Then 'matching the columns
            arr3(i, nr) = arr2(i, nr) 'arr3 last column of arr3 is equal to last column of arr1
        End If

Basically, my key column for matching (rng1) is in the middle of the table.
Columns I am trying to copy are for example last 5 columns of the sheet. But there are several columns to copy. In your example I think you copy only one column.

 

[JackDanIce]

You're using .Select as well as a nested loop, neither are recommended if you want faster code

Can you share screenshots (with column headers. row numbers and sheet names), to better understand what you mean?

What does the data look like before the code runs and what should it look like, after the code has run?

 

[igold]

I tested it extensively with no errors (on my imagined data). What was the error you got. If you could supply some sample data as suggested by @JackDanIce that would be great. The line you got the error on is the very last line which is going to write the data back to your workbook on "Sheet1". Is that the correct name of the sheet.

Also, as pointed out, your code is slow because it is constantly going back to the sheet to get and write information within your loop- that should never happen. All calculations should be done in memory.

Additionally, the way you worded your question:

values in key column on worksheet 1 with one by one value in key column in worksheet 2

led me to believe that it was one column only on each sheet.

 

[Miro H]

You're using .Select as well as a nested loop, neither are recommended if you want faster code

Can you share screenshots (with column headers. row numbers and sheet names), to better understand what you mean?

What does the data look like before the code runs and what should it look like, after the code has run?

I'm using select outside the loop. The problem is in the loop.

I suppose arrays inside the loop would be much faster but I don't know how to copy several columns efficiently. Other than making another loop that goes through columns.

I've attached the example sheets.

Column for matching with unique values is column F. Columns for copy from Sheet 2 to Sheet 1 would be K to O.

Each sheet has some 3000 rows, row numbers in each sheet are not the same. Entries change places.

 

[Miro H]

I tested it extensively with no errors (on my imagined data). What was the error you got. If you could supply some sample data as suggested by @JackDanIce that would be great. The line you got the error on is the very last line which is going to write the data back to your workbook on "Sheet1". Is that the correct name of the sheet.

Also, as pointed out, your code is slow because it is constantly going back to the sheet to get and write information within your loop- that should never happen. All calculations should be done in memory.

Additionally, the way you worded your question:

led me to believe that it was one column only on each sheet.

Aha, OK, I suppose that was the error. Sheet1 is not the name of the sheet. That's why I reference it in the code as Worksheets(1).

There is not one column, but multiple columns for copying. I don't know how to do calculations in memory except through arrays with additional loops for columns. So there would be several additional loops inside loops. I don't know if this is the best way to approach the problem?

I've posted example of the sheets in post above.

 

[JackDanIce]

Are the SA_ID's or PROJECT_NO's unique?

If so, try going back to basics, forget VBA and manually apply an XLOOKUP formula and fill down the 4 columns, use IFERROR around XLOOKUP for values not found.

Next, delete any columns you don't want and copy and paste the formula results as values.


If this works, you can record a macro that repeats the above and use that as a starting base for your macro which now avoids looping and modify it for a selected user column.

If speed is still an issue, post the new code and see if a reader can suggest using arrays, dictionaries etc.

Or you could use Power Query, which would remove much of the VBA, but may require a redesign of your worksheets.

 

[igold]

If you are saying that the column letters are not going to change- as in you will always be matching the values in Column F from both sheets and copying the corresponding information from Columns K to O, then does this do what you want...

Sub MatchAndCopy()

    Dim arr1, arr2, arr3
    Dim nrs1 As Long, nrs2 As Long, i As Long, nr As Long, j As Long
    Dim ws1 As Worksheet: Set ws1 = Worksheets(1)
    Dim ws2 As Worksheet: Set ws2 = Worksheets(2)
    Dim hdr
  
    Application.ScreenUpdating = False
   
    nrs1 = ws1.Cells(Rows.Count, "F").End(xlUp).Row
    nrs2 = ws2.Cells(Rows.Count, "K").End(xlUp).Row
    arr1 = ws1.Range("F1:F" & nrs1)
    arr2 = ws2.Range("F1:O" & nrs2)
    nr = 1
    hdr = ws2.Range("K1:O1")
    ReDim arr3(1 To UBound(arr2), 1 To 5)
   
    For i = 2 To UBound(arr2)
        If arr1(i, 1) = arr2(i, 1) Then
            For j = 1 To 5
                arr3(nr, j) = arr2(i, j + 5)
            Next
        End If
       nr = nr + 1
    Next

    ws1.Range("K1:O1") = hdr
    ws1.Range("K2").Resize(UBound(arr3, 1), UBound(arr3, 2)) = arr3
   
    Application.ScreenUpdating = True
    MsgBox "Operation Complete"
   
End Sub

 

[igold]

Please disregard the code in my Post #9 and use this one instead. The previous code would fail if Column K was not the longest Column of data- my bad!

Sub MatchAndCopy()

    Dim arr1, arr2, arr3, hdr
    Dim nrs1 As Long, i As Long, nr As Long, j As Long
    Dim ws1 As Worksheet: Set ws1 = Worksheets(1)
    Dim ws2 As Worksheet: Set ws2 = Worksheets(2)
   
    Application.ScreenUpdating = False
    
    nrs1 = ws1.Cells(Rows.Count, "F").End(xlUp).Row
    arr1 = ws1.Range("F1:F" & nrs1)
    arr2 = ws2.Range("F1:O" & nrs1)
    nr = 1
    hdr = ws2.Range("K1:O1")
    ReDim arr3(1 To UBound(arr2), 1 To 5)
    
    For i = 2 To UBound(arr2)
        If arr1(i, 1) = arr2(i, 1) Then
            For j = 1 To 5
                arr3(nr, j) = arr2(i, j + 5)
            Next
        End If
       nr = nr + 1
    Next

    ws1.Range("K1:O1") = hdr
    ws1.Range("K2").Resize(UBound(arr3, 1), UBound(arr3, 2)) = arr3
    
    Application.ScreenUpdating = True
    MsgBox "Operation Complete"
    
End Sub