How to match multiple columns and get value?

user_19120521 0
Viewed 283

I'm trying to match values in two tables and to copy the value in a destination table.

I understand this requires multiple loops / conditions.

The goal is to copy the matching values from source table (SE) to each row in destination table (FB) using the match in the helper table (SA).

What I want to achieve:
Tables.jpg

There is no unique key value in column 'C' at table 'SA'.

My code so far:

Sub MatchTables()

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim i As Long, j As Long
    Dim newSheetPos As Integer

    Set ws1 = ActiveWorkbook.Sheets("FB") 'Range: last row
    Set ws2 = ActiveWorkbook.Sheets("SA") 'Range: rows 5 to 84
    Set ws3 = ActiveWorkbook.Sheets("SE") 'Range: last row

    For i = 2 To ws1.Cells(ws1.Rows.Count, 3).End(xlUp).Row
        For j = 5 To 84

            If ws1.Cells(i, 3).Value = ws2.Cells(j, 3).Value Then
                If ws2.Cells(i, 3).Value = ws3.Cells(j, 5).Value Then
                    ws3.Cells(j, 6).Copy ws1.Cells(i , 16)
                Else
                End If
            Else
            End If

        Next j
    Next i
End Sub
matching lookup vba excel loops
1 Answers

(Super) Double Lookup

  • To simplify, it is assumed that each of the lookup columns contains at least 2 rows of data and no error values or blanks.
Sub SuperLookup()

    Const sName As String = "SE"
    Const sfRow As Long = 2
    Const slCol As String = "E" ' 4.) ... here and return...
    Const svCol As String = "F" ' 5.) ... this...
    
    Const lName As String = "SA"
    Const lRowsAddress As String = "5:84"
    Const llCol As String = "C" ' 2.) ... here and return...
    Const lvCol As String = "Q" ' 3.) ... this to look it up...
    
    Const dName As String = "FB"
    Const dfRow As Long = 2
    Const dlCol As String = "C" ' 1.) Look up this...
    Const dvCol As String = "P" ' 6.) ... here.
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
    Dim srg As Range
    Set srg = sws.Cells(sfRow, slCol).Resize(slRow - sfRow + 1)
    Dim sData As Variant: sData = srg.EntireRow.Columns(svCol).Value
    
    Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
    Dim lrg As Range: Set lrg = lws.Rows(lRowsAddress).Columns(llCol)
    Dim lData As Variant: lData = lrg.EntireRow.Columns(lvCol).Value
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dlCol).End(xlUp).Row
    Dim drCount As Long: drCount = dlRow - dfRow + 1
    Dim drg As Range: Set drg = dws.Cells(dfRow, dlCol).Resize(drCount)
    Dim dlData As Variant: dlData = drg.Value
    Set drg = drg.EntireRow.Columns(dvCol)
    Dim dvData As Variant: ReDim dvData(1 To drg.Rows.Count, 1 To 1)
    
    Dim sIndex As Variant
    Dim lIndex As Variant
    Dim lValue As Variant
    Dim dValue As Variant
    Dim dr As Long
    
    For dr = 1 To drCount
        dValue = dlData(dr, 1)
        lIndex = Application.Match(dValue, lrg, 0)
        If IsNumeric(lIndex) Then
            lValue = lData(lIndex, 1)
            sIndex = Application.Match(lValue, srg, 0)
            If IsNumeric(sIndex) Then
                dvData(dr, 1) = sData(sIndex, 1)
            'Else ' not found in source; do nothing
            End If
        'Else ' not found in lookup; do nothing
        End If
    Next dr

    drg.Value = dvData
    
    MsgBox "Super lookup has finished.", vbInformation

End Sub
user_98140690
Related