How to compare Workbook A two specific columns with Workbook B two specific columns and if they Matc-CodePudding

Link for the workbooks to see this specific case:

I have A code from VBasic2008, which does this Exact Job, but only compares one column from WB A(Source) and one column from WB B(Destination) and takes only two specific columns from WB A to WB B, whereas in Id need three columns to be taken if the compared multiple columns match and placed into specific columns in WB B (Destination).

The code:

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

CodePudding user response：

A VBA Lookup: Match and Return Multiple Columns

Sub MultiLookupData()

    ' Define constants.

    Const SRC_FILE_NAME As String = "Source.xlsx"
    Const SRC_WORKSHEET_ID As Variant = 1
    Const SRC_LOOKUP_COLUMNS As String = "A,F"
    Const SRC_VALUE_COLUMNS As String = "C,E,G"

    Const DST_FILE_NAME As String = "Destination.xlsx"
    Const DST_WORKSHEET_ID As Variant = 1
    Const DST_LOOKUP_COLUMNS As String = "D,F"
    Const DST_VALUE_COLUMNS As String = "H,I,J"
    
    Const LOOKUP_DELIMITER As String = "@@"
    
    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 columns
    ' to arrays of the jagged Source Lookup array.
    
    Dim slCols() As String: slCols = Split(SRC_LOOKUP_COLUMNS, ",")
    Dim nlUpper As Long: nlUpper = UBound(slCols)
    
    Dim slJag() As Variant: ReDim slJag(0 To nlUpper)
    
    Dim n As Long
    
    For n = 0 To nlUpper
        slJag(n) = srg.Columns(slCols(n)).Value
    Next n
    
    ' Write the concatenated unique values from the arrays
    ' of 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(slJag(0)(sr, 1))
        For n = 1 To nlUpper
            sString = sString & LOOKUP_DELIMITER & CStr(slJag(n)(sr, 1))
        Next n
        If Not dict.Exists(sString) Then dict(sString) = sr
    Next sr
        
    Erase slJag ' data is in the dictionary
        
    ' Write the values from the Source Value columns to arrays
    ' of the jagged Source Value array.
    
    Dim svCols() As String: svCols = Split(SRC_VALUE_COLUMNS, ",")
    Dim nvUpper As Long: nvUpper = UBound(svCols)
    
    Dim svJag() As Variant: ReDim svJag(0 To nvUpper)
    
    For n = 0 To nvUpper
        svJag(n) = srg.Columns(svCols(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 columns
    ' to arrays of the jagged Destination Lookup array.
    
    Dim dlCols() As String: dlCols = Split(DST_LOOKUP_COLUMNS, ",")
    
    Dim dlJag() As Variant: ReDim dlJag(0 To nlUpper)
    
    For n = 0 To nlUpper
        dlJag(n) = drg.Columns(dlCols(n)).Value
    Next n
    
    ' Copy empty arrays for the Desetination Value columns
    ' to the jagged Destination Value array.
    
    Dim dvCols() As String: dvCols = Split(DST_VALUE_COLUMNS, ",")
    
    Dim dvJag() As Variant: ReDim dvJag(0 To nvUpper)
    
    Dim dvHelp() As Variant: ReDim dvHelp(1 To drCount, 1 To 1)
    
    For n = 0 To nvUpper
        dvJag(n) = dvHelp
    Next n

    Erase dvHelp

    ' Comparing the concatenated values of the arrays
    ' of the Destination Lookup array with the 'keys' of 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(dlJag(0)(dr, 1))
        For n = 1 To nlUpper
            dString = dString & LOOKUP_DELIMITER & CStr(dlJag(n)(dr, 1))
        Next n
        If dict.Exists(dString) Then
            For n = 0 To nvUpper
                dvJag(n)(dr, 1) = svJag(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 nvUpper
        drg.Columns(dvCols(n)).Value = dvJag(n)
    Next n
    
    ' Save and close the workbooks.
    
    dwb.Close SaveChanges:=True
    swb.Close SaveChanges:=True
    
    ' Inform.
    
    MsgBox "Data looked up.", vbInformation

End Sub