VBA - Vlookup Multiple Columns and Fill to End of Range

Question

I need to do a Vlookup of an ID on the source sheet to a table in the data sheet. When the Vlookup is done, it needs to return the cell values from 6 different columns.

Here I have a function to get the range:

Function find_Col(header As String) As Range

    Dim aCell As Range, rng As Range, def_Header As Range
    Dim col As Long, lRow As Long, defCol As Long
    Dim colName As String, defColName As String
    Dim y As Workbook
    Dim ws1 As Worksheet

    Set y = Workbooks("Template.xlsm")
    Set ws1 = y.Sheets("Results")

    With ws1

        Set def_Header = Cells.Find(what:="ID", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
        Set aCell = .Range("B2:Z2").Find(what:=header, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then

            defCol = def_Header.Column
            defColName = Split(.Cells(, defCol).Address, "$")(1)

            col = aCell.Column
            colName = Split(.Cells(, col).Address, "$")(1)

            lRow = Range(defColName & .Rows.count).End(xlUp).Row - 1

            Set myCol = Range(colName & "2")

            'This is your range
            Set find_Col = Range(myCol.Address & ":" & colName & lRow).Offset(1, 0)

        'If not found
        Else

            MsgBox "Column Not Found"

        End If

    End With

End Function

Then in my sub, I select the range and do a Vlookup which fills this range:

Selection.FormulaR1C1 = "=VLOOKUP(RC[-4],myTable,2,FALSE)"

And this works great.

Then I needed to return more than just one column, so I ended up with the formula:

Selection.FormulaArray = "=VLOOKUP($C3,myTable,{2,3,4,5,6},FALSE)"

Source Sheet:

Data Sheet:

So, my function returns only the range for one column, which I think I can use in terms of getting a row count then using something like this:

Set myRng = find_Col("Product")

For currentRow = myRng.Rows.count To 1 Step -1

Selection.FormulaArray = "=VLOOKUP($C3,myTable,{2,3,4,5,6},FALSE)"

Next currentRow

Then perhaps instead of C3 it could look something like this:

C & currentRow --> Selection.FormulaArray = "=VLOOKUP($C & currentRow,myTable,{2,3,4,5,6},FALSE)"

But then I have the issue that only one cell is selected (G3) and from H-L is not. And I have no idea whether this is even a plausible effort.

Ideally of course, I would have cells G3:L3 selected and fill the formula down to the last row.

My brain is just fried from all the thinking and attempts.

Answer 1

So this should do the trick... I've explained every instance but if you need help understanding just ask:

Option Explicit
Sub FillData1()

    Dim ws As Worksheet, wsData As Worksheet, arr As Variant, arrData As Variant
    Dim DictHeaders As Scripting.Dictionary, DictIds As Scripting.Dictionary, DictDataHeaders As Scripting.Dictionary, _
    DictDataIds As Scripting.Dictionary
    Dim LastRow As Long, LastCol As Integer, i As Long, j As Integer

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    With ThisWorkbook
        Set ws = .Sheets("Results")
        Set wsData = .Sheets("List")
    End With

    'Lets suppose your data always starts on row 2 in both sheets and column B will always have the max amount of rows filled
    With ws 'filling the first array
        LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
        LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
        arr = .Range("B2", .Cells(LastRow, LastCol)).Value
    End With

    With wsData 'filling the data array
        LastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
        LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
        arrData = .Range("A2", .Cells(LastRow, LastCol)).Value
    End With

    'Now lets put everything into Dictionaries so if the data moves columns or rows won't matter
    Set DictHeaders = New Scripting.Dictionary
    Set DictIds = New Scripting.Dictionary
    For i = 1 To UBound(arr, 2) 'this will fill the headers positions on the main sheet
        If Not DictHeaders.Exists(arr(1, i)) Then DictHeaders.Add arr(1, i), i
    Next i
    For i = 2 To UBound(arr, 1) 'this will fill the IDs positions on the main sheet
        If Not DictIds.Exists(arr(i, DictHeaders("KW ID"))) Then DictIds.Add arr(i, 1), i
    Next i

    Set DictDataHeaders = New Scripting.Dictionary
    Set DictDataIds = New Scripting.Dictionary
    For i = 1 To UBound(arrData, 2) 'this will fill the headers positions on the data sheet
        If Not DictDataHeaders.Exists(arrData(1, i)) Then DictDataHeaders.Add arrData(1, i), i
    Next i
    For i = 2 To UBound(arrData, 1) 'this will fill the IDs positions on the data sheet
        If Not DictDataIds.Exists(arrData(i, DictDataHeaders("KW ID"))) Then DictDataIds.Add arrData(i, DictDataHeaders("KW ID")), i
    Next i

    'Finally will loop through the main array to fill it with the data from the data array
    On Error Resume Next
    For i = 2 To UBound(arr)
        For j = 6 To UBound(arr, 2) 'I'm assuming you want to avoid the first columns which are hidden
            arr(i, j) = arrData(DictDataIds(arr(i, 1)), DictDataHeaders(arr(1, j)))
        Next j
    Next i
    On Error GoTo 0

    With ws 'filling the first array
        LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
        LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
        .Range("B2", .Cells(LastRow, LastCol)).Value = arr
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

Answer 2

I don't know if I got the true issue of your goal. However, since your Selection parts in your code should be avoid, why don't make something like the following?

Set myRng = find_Col("Product")

For currentRow = myRng.Rows.count To 1 Step -1

    Range(Cells(currentRow, 5), Cells(currentRow, 9)).FormulaArray = "=VLOOKUP(RC3,myTable,{2,3,4,5,6},FALSE)"

Next currentRow