VBA - Vlookup несколько столбцов и заполнить до конца диапазона

Question

Мне нужно сделать Vlookup ID на исходном листе для таблицы в листе данных.Когда Vlookup завершен, он должен вернуть значения ячеек из 6 различных столбцов.

Здесь у меня есть функция для получения диапазона:

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

Затем в моем сабвуфере я выбираюдиапазон и выполнить Vlookup, который заполняет этот диапазон:

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

И это прекрасно работает.

Затем мне нужно было вернуть более одного столбца, поэтому я получил формулу:

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

Исходный лист:

Лист данных:

Итак, моя функция возвращает только диапазон для одного столбца, который, я думаю, я могу использовать с точки зрения получения количества строк, используя что-то вроде этого:

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

Тогда, возможно, вместо C3 это может выглядеть примерно так:

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

Но тогда у меня проблема в том, что выбрана только одна ячейка(G3) и от HL нет.И я понятия не имею, является ли это даже правдоподобным усилием.

В идеале, конечно, я бы выделил ячейки G3:L3 и заполнил формулу до последнего ряда.

Мой мозгпросто жарен от всех мыслей и попыток.

Answer 1

Так что это должно сработать ... Я объяснил каждый случай, но если вам нужна помощь в понимании, просто спросите:

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

Я не знаю, правильно ли я понял вашу цель. Однако, поскольку ваши Selection части в вашем коде следует избегать, почему бы не сделать что-то вроде следующего?

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