Search In Other Workbook - Copy/Paste Offset Data To First Workbook - Repeat Process

[Logit]

I'm wanting to search a numerical term WB1 Column B, that might be found in WB2 Column B. If found, copy data from same row Column E and paste same in WB 1 Column E.
There are links below to download both example workbooks with only 20 rows of data as a sample.

Here is a macro I've tried but it probably needs to be edited for efficiency. My computer runs Win 10/64 bit with 16 gb of RAM ... however, it strains to loads both workbooks and perform the search/copy/paste actions. Any edits to the following macro to make it a lot more efficient with my computer's resources is greatly appreciated.

Sub CopyDataBasedOnUniqueTerms()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim uniqueTerm As String
    Dim lastRow As Long, searchRow As Long
    Dim foundCell As Range
   
    Set wb1 = Workbooks("WB 1.xlsb")
    Set wb2 = Workbooks("WB 2.xlsb")
    Set ws1 = wb1.Sheets(1)
   
    lastRow = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
   
    For searchRow = 1 To lastRow
        uniqueTerm = ws1.Cells(searchRow, "B").Value
        Set foundCell = Nothing
       
        For Each ws2 In wb2.Sheets
            Set foundCell = ws2.Columns("B").Find(What:=uniqueTerm, LookIn:=xlValues, LookAt:=xlPart)
            If Not foundCell Is Nothing Then
                ws1.Cells(searchRow, "E").Value = ws2.Cells(foundCell.Row, "E").Value
                Exit For
            End If
        Next ws2
    Next searchRow
End Sub

WB 1 : https://share.eu.internxt.com/d/sh/file/63f79da8-8bba-4da7-b05a-ed490167cac3/616323cfdd4ff06bc873a5647c6e03767b0496a6becd7245119ee3b21eba206d

WB 2 : WB 2 : https://share.eu.internxt.com/d/sh/file/6170755e-8cdb-40a7-8cae-03b404a0b070/39283917b47a0715c70fd46ac9e4ec6d9899d37b122787cef43a94a291e7d1c0


Any assistance is greatly appreciated.

 

[Logit]

My apologies for the two links provided. For some reason the MrExcel servers manipulated the links. Here they are again and hopefully displayed correctly :

WB 1 :

Internxt Drive – Private & Secure Cloud Storage


WB 2 :

Internxt Drive – Private & Secure Cloud Storage

 

[Alex Blakenburg]

Can you update your account profile to show what version of Excel you are using.
Have you considered using Power Query to do this ?

Give this a try, it is based on your sample data which indicates an "Exact match" is possible.
Your current find uses "xlPart". The below won't work if you really are looking for a partial match.

Note:
• You might need to consider using an If Statement to exclude any sheets that you need to exclude.
I have left my exclusion of my Notes sheet as an example in the output (wb1) loop.
• You could also close wb2 after the collection has been loaded

You could in principle close your wb2 after the collection has been loaded.

Sub CopyDataBasedOnUniqueTerms_Collection()
    Dim dStart As Double                                ' For testing only
    dStart = Timer                                      ' For testing only

    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim arr1 As Variant, arr2 As Variant
    Dim coll2 As Collection
    Dim i As Long
   
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
   
    Set wb1 = ThisWorkbook                              ' Change as required - lookup value
    Set wb2 = Workbooks("HD 3.xlsb")                    ' Change as required - lookup array
    Set coll2 = New Collection
   
    ' Load collection from wb2
    For Each ws2 In wb2.Worksheets
        With ws2
            If .Range("B" & Rows.Count) = "" Then
                lastRow2 = .Range("B" & Rows.Count).End(xlUp).Row
            Else
                lastRow2 = Rows.Count
            End If
            arr2 = .Range("B1:E" & lastRow2)
            On Error Resume Next
            For i = 1 To lastRow2
                coll2.Add Item:=arr2(i, 4), key:=CStr(arr2(i, 1))
            Next i
            On Error GoTo 0
        End With
    Next ws2
   
    Erase arr2

    Debug.Print Timer - dStart                            ' For testing only
   
    ' Retrieve Values for wb1
    On Error Resume Next
    For Each ws1 In wb1.Worksheets
        If ws1.Name <> "Notes" Then                            ' Sheets to exclude
            With ws1
                If .Range("B" & Rows.Count) = "" Then
                    lastRow1 = .Range("B" & Rows.Count).End(xlUp).Row
                Else
                    lastRow1 = Rows.Count
                End If
               
                arr1 = .Range("B1:E" & lastRow2)
                On Error Resume Next
                For i = 1 To lastRow2
                    arr1(i, 4) = coll2(CStr(arr1(i, 1)))
                Next i
               
                On Error GoTo 0
                .Range("E1:E" & lastRow2) = Application.Index(arr1, 0, 4)
            End With
        End If
    Next ws1
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    Debug.Print Timer - dStart                            ' For testing only
End Sub

 

[Logit]

I've never used Power Query although I do understand how effective it can be. Primarily I use Excel 2007. I have 2019 but not loaded on my computer.

Test drove your macro and found it to be effective with the sample data. Now I need to test it with the full database which, as previously stated, comprises all 4 sheets in Workbook #2.
That's a lot of rows to search through.

Thank you for your submission. I will let you know how well thing work with the full database.

 

[Alex Blakenburg]

I tested it on 3M records in wb2 and 1M in in wb1 and it ran in under 1 minute.
As long as an entire contents match (exact match but not case sensitive) works then using a collection should be the fastest way.

 

[Logit]

Thank you for testing it on your side. My present computer is having multiple issues. It is doing things it shouldn't and not doing things it should.
One issue is with the video. I believe the onboard video circuitry is slowing going bad and there may well be other issues I can't pin down.

Im purchasing a new computer with 64 gb of RAM and a beefed up video card. I am hopeful this will clear up my computer issues and perhaps
things will run smoother working in Excel.

I'll keep you updated on my progress.

Thanks.

 

[RoryA]

This appears to be the same question you posted here: https://www.excelforum.com/excel-pr...64-search-copy-paste-between-2-workbooks.html

If so, you ought to know the rules by now...

 

[Logit]

Thank you.