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），而从H-L中没有被选中。而且我不知道这是否是合理的尝试。

当然，理想情况下，我会选择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

VBA-Vlookup多列并填充到范围的末尾

2 个答案: