VLookUp一对多升级版，可以返回所有匹配结果，支持多列或多行作为搜索和返回区域

函数名称：LookUpAllMatches

参数	使用方法
lookup_value	查找值。必填字段。填写需要查找的值，或者选择需要查找的值所在的单元格。
match_range	匹配区域。必填字段。选取lookup_value的查找区域，也就是你要在哪里找lookup_value。通常选取一整列。
return_range	返回区域。必填字段。选取需要返回的区域，通常选取与match_range相邻的某一列。也就是说，当你在match_range的某一行中找到lookup_value后，你要返回这一行中哪一列的值，或者说，你要返回这一行与哪一列相交处的单元格的值。
return_array	是否返回数组。可选参数。默认值为False，不返回数组，将所有匹配返回到一个单元格中，用逗号隔开。如果填True，函数就会返回数组，即把匹配结果返回到多个单元格内。这时需要将该公式中的引用转换为绝对引用，并复制到多个单元格，同时选中这些单元格后，按ctrl+shift+enter结束输入。此时公式会被一对大括号"{}"包括，意为该函数为数组函数(array formula)，他的返回结果分散在多个单元格中。
remove_duplicate	是否去除返回结果中的重复项。可选参数。默认值为False，即不开启去除重复功能。填True开启去重功能。
delimiter	分隔符。可选参数。默认值为英文逗号","。该参数用来自定义返回结果中的分隔符。如果return_array填true，则该参数失效。

已经包含该函数代码的xlsm文件下载链接：https://share.weiyun.com/1bc9975dc80bd29505c2110f7c5d3fcf

打开该文件后需开启宏。

 

如需在输入函数时获取参数提示，可以先在单元格中输入=LookUpAllMatches()，然后按Shift+F3，就会弹出参数输入辅助界面。如下图。

 

 

如果您想学习一下如何自己插入VBA源代码，可以按照以下方法将下文中的VBA代码插入Excel工作簿：

先在Excel中按Alt+F11，进入VBE编辑器。然后在左侧找到需要插入代码的工作簿(Workbook)的名称。如果VBE编辑器左侧看不到这一块Project小窗口，可以试试看按Ctrl+R。

在下图中，我希望在工作簿Book1中插入代码，所以就选中了VBAProject (Book1)这一层。

右键单击该工作簿名称，依次点击Insert -- Module。

这时VBE左侧就会多出一个Module1，双击该Module1，在右侧代码输入界面中，将本文下面的代码复制粘贴进去。

 

本自定义函数由于使用了第三方库，使用前需要做Early Binding：即在VBE编辑器中，选择菜单栏中的Tool — Reference：

弹出如下图的对话框后，选择Microsoft Scripting Runtime，打钩，点OK。

最后按Ctrl+S保存文件，注意在保存对话框中，文件类型需要选择“Excel启动宏的工作簿(*.xlsm)”，如下图

 

Sub Test()
Dim lookup_value As Long
Dim match_range As Range, return_range As Range
lookup_value = 27043
Set match_range = Columns(1).EntireColumn
Set return_range = Columns(3).EntireColumn

Debug.Print LookUpAllMatches(lookup_value, match_range, return_range)

End Sub

Public Function LookUpAllMatches(ByVal lookup_value As String, ByVal match_range As Range, _
    ByVal return_range As Range, Optional ByVal return_array = False, _
    Optional ByVal remove_duplicate = False, Optional ByVal delimiter As String = ",")

'By Jing He 2017-12-28
'Last update 2023-08-17
'Last Function Added:
'2023-08-18 Let function return #N/A when hit 0 matche
'2023-08-17 Modify zTrim_Range function to support multi-sheet match

Dim match_index() As Long, result_set() As String
ReDim match_index(1 To match_range.Cells.Count)

Set match_range = zTrim_Range(match_range)
Set return_range = zTrim_Range(return_range)

If match_range.Count <> return_range.Count Then
    LookUpAllMatches = "Number of cells in trimed match_range and in trimed return_range are not equal."
    Exit Function
End If

Dim i As Long, mc As Long   'used to count, to get the index of a cell in a range
mc = 0  'match count
For i = 1 To match_range.Cells.Count
    If match_range.Cells(i).Value = lookup_value Then
        mc = mc + 1
        match_index(mc) = i
    End If
Next i

If mc = 0 Then
    LookUpAllMatches = CVErr(xlErrNA)
    Exit Function
End If

'Removing duplicate process. Use Scripting.Dictionary object.

If remove_duplicate Then
    Dim d As Dictionary, key As String
    Set d = New Dictionary
    For i = 1 To mc
        key = return_range.Cells(match_index(i)).Value
        If Not d.Exists(key) Then d.Add key, key
    Next i
    ReDim result_set(1 To d.Count)
    'Convert the hashtable to a array of all the values
    its = d.Items
    'the index of this items array starts at 0 instead of 1 which is the standard for all the other arraries in ths UDF.
    For i = 0 To d.Count - 1
        result_set(i + 1) = its(i)
    Next i
    'close the object; release memeory
    Set d = Nothing
Else
    ReDim result_set(1 To mc)
    For i = 1 To mc
        result_set(i) = return_range.Cells(match_index(i)).Value
    Next i
End If
If return_array Then
    LookUpAllMatches = result_set
    Exit Function
End If

Dim result As String
'Convert result_set to a single-line text
result = result_set(1)
For i = 2 To UBound(result_set)
    result = result & delimiter & result_set(i)
Next i

LookUpAllMatches = result

End Function

Function zTrim_Range(ByVal rng As Range) As Range
'By Jing He 2017-12-29
'Last update 2017-12-29

Dim maxRow As Long, maxUsedRow As Long, maxUsedRowTemp As Long

maxRow = Columns(1).Cells.Count
Set rngSheet = rng.Parent

If rng.Cells.Count \ maxRow <> 0 Then
    'One or multiple columns selected
    For i = 1 To rng.Columns.Count
        If rngSheet.Cells(maxRow, rng.Cells(1, i).Column) = "" Then
            maxUsedRowTemp = rngSheet.Cells(maxRow, rng.Cells(1, i).Column).End(xlUp).Row
            If maxUsedRowTemp > maxUsedRow Then maxUsedRow = maxUsedRowTemp
        End If
    Next i
    Set zTrim_Range = Intersect(rng, Range(rngSheet.Rows(1), rngSheet.Rows(maxUsedRow)))
Else
    Set zTrim_Range = rng
End If

End Function