VBA-Vlookup多列並填充到范圍的結尾

Question

我需要對源工作表中的ID進行Vlookup到數據表中的表。 完成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