https://easyupload.io/m/g9i8nz Link of the workbooks. ( This is link for the workbooks with explanation in there)

I need to Compare specific columns in Workbook A with Workbook B specific columns and if values match it should take two other specific columns from source Workbook A and paste into Destination Workbook B specific columns specifically where the match was found. I have a similar code, which was found in Mr. Excel forum By moderator : Fluff. Which does find the matches using dictionary and arrays, which reduce the work time for the macro if our ranges are huge. But that code pastes the whole row and also paste to the last found row, where I as explained above need something modified. I would be glad to receive some advice or assistance or guidance on how to tackle this. Thank you!

The code: '''

 Sub Match()
 Dim WbkA As Workbook, WbkB As Workbook, WbkC As Workbook
 Dim Ary As Variant, Nary As Variant
 Dim Dic As Object
 Dim r As Long, c As Long, nr As Long

 Set WbkA = Workbooks.Open(Application.DefaultFilePath & "\" & "WorkbookA.xlsx")
 Set WbkB = Workbooks.Open(Application.DefaultFilePath & "\" & "WorkbookB.xlsx")
 Set WbkC = Workbooks.Open(Application.DefaultFilePath & "\" & "ReferenceList.xlsx")
 Set Dic = CreateObject("scripting.dictionary")
 Dic.comparemode = 1

 With WbkC.Sheets(1)
    Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
 End With
 For r = 1 To UBound(Ary)
    Dic(Cl.Value) = Empty
 Next r
 With WbkA.Sheets(1)
    c = .Cells(1, Columns.Count).End(xlToLeft).Column
    Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, c).Value2
 End With

 ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
 For r = 1 To UBound(Ary)
    If Dic.Exists(Ary(r, 5)) Then
       nr = nr   1
       For c = 1 To UBound(Ary, 2)
          Nary(nr, c) = Ary(r, c)
       Next c
    End If
 Next r
 Wbk.Sheets(1).Range("A1").Resize(nr, UBound(Nary, 2)).Value = Nary

 WbkA.Close True
 WbkB.Close True
 end sub

'''

PS. Code above has three workbooks above, but simply deleting Wbkc does the job and replacing Wbkc with WBKB.

CodePudding user response：

A VBA Lookup: Return Multiple Columns

Sub LookupData()

    ' Define constants.

    Const SRC_FILE_NAME As String = "Source.xlsx"
    Const SRC_WORKSHEET_ID As Variant = 1
    Const SRC_LOOKUP_COLUMN As String = "A"
    Const SRC_VALUE_COLUMNS As String = "C,E"
    
    Const DST_FILE_NAME As String = "Destination.xlsx"
    Const DST_WORKSHEET_ID As Variant = 1
    Const DST_LOOKUP_COLUMN As String = "D"
    Const DST_VALUE_COLUMNS As String = "H,I"
    
    Dim FolderPath As String: FolderPath = Application.DefaultFilePath & "\"
    
    ' Reference the Source range.
    
    Dim swb As Workbook: Set swb = Workbooks.Open(FolderPath & SRC_FILE_NAME)
    Dim sws As Worksheet: Set sws = swb.Sheets(SRC_WORKSHEET_ID)
    
    Dim srg As Range, srCount As Long
    
    With sws.Range("A1").CurrentRegion
        srCount = .Rows.Count - 1 ' exclude headers
        Set srg = .Resize(srCount).Offset(1)
    End With
    
    ' Write the values from the Source Lookup column
    ' to the Source Lookup array.
    
    Dim slData() As Variant: slData = srg.Columns(SRC_LOOKUP_COLUMN).Value
    
    ' Write the unique values from the Source Lookup array to the 'keys'
    ' of a dictionary and the associated rows to its 'items'.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim sr As Long, sString As String
    
    For sr = 1 To srCount
        sString = CStr(slData(sr, 1))
        If Not dict.Exists(sString) Then dict(sString) = sr
    Next sr
        
    Erase slData ' data is in the dictionary
        
    ' Write the values from the Source Value columns to arrays
    ' of the jagged Source Value array.
    
    Dim sCols() As String: sCols = Split(SRC_VALUE_COLUMNS, ",")
    Dim nUpper As Long: nUpper = UBound(sCols)
    
    Dim sJag() As Variant: ReDim sJag(0 To nUpper)
    
    Dim n As Long
    
    For n = 0 To nUpper
        sJag(n) = srg.Columns(sCols(n)).Value
    Next n
        
    ' Reference the Destination range.
        
    Dim dwb As Workbook: Set dwb = Workbooks.Open(FolderPath & DST_FILE_NAME)
    Dim dws As Worksheet: Set dws = dwb.Sheets(DST_WORKSHEET_ID)
    
    Dim drg As Range, drCount As Long
    
    With dws.Range("A1").CurrentRegion
        drCount = .Rows.Count - 1 ' exclude headers
        Set drg = .Resize(drCount).Offset(1)
    End With
    
    ' Write the values from the Destination Lookup column
    ' to the Destination Lookup array.
    
    Dim dlData() As Variant: dlData = drg.Columns(DST_LOOKUP_COLUMN).Value
    
    ' Copy empty arrays for the Desetination Value columns
    ' to the jagged Destination Value array.
    
    Dim dCols() As String: dCols = Split(DST_VALUE_COLUMNS, ",")
    
    Dim dJag() As Variant: ReDim dJag(0 To nUpper)
    
    Dim dHelp() As Variant: ReDim dHelp(1 To drCount, 1 To 1)
    
    For n = 0 To nUpper
        dJag(n) = dHelp
    Next n

    Erase dHelp

    ' Comparing the Destination Lookup array with the dictionary,
    ' write the matching data from the arrays of the Source Value array
    ' to the arrays of the Destination Value array.

    Dim dr As Long, dstring As String
    
    For dr = 1 To drCount
        dstring = CStr(dlData(dr, 1))
        If dict.Exists(dstring) Then
            For n = 0 To nUpper
                dJag(n)(dr, 1) = sJag(n)(dict(dstring), 1)
            Next n
        End If
    Next dr
    
    ' Write the values from the arrays of the Destination Value array
    ' to the Destination Value columns.
    
    For n = 0 To nUpper
        drg.Columns(dCols(n)).Value = dJag(n)
    Next n
    
    ' Save and close the workbooks.
    
    dwb.Close SaveChanges:=True
    swb.Close SaveChanges:=True
    
    ' Inform.
    
    MsgBox "Data looked up.", vbInformation

End Sub