excel - 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

然后在我的 sub 中，我选择范围并执行填充此范围的 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选择单元格并将公式填充到最后一行。

我的大脑刚刚被所有的思考和尝试煎炸了。

标签： excelvba

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