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文件下載鏈接：http://url.cn/5aNlO4J

打開該文件后需開啟宏。

 

如需在輸入函數時獲取參數提示，可以先在單元格中輸入=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)”，如下圖

 

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-29
'Last update 2018-02-02
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 Exit Function

'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

If rng.Cells.Count \ maxRow <> 0 Then
    'One or multiple columns selected
    For i = 1 To rng.Columns.Count
        If Cells(maxRow, rng.Cells(1, i).Column) = "" Then
            maxUsedRowTemp = 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(Rows(1), Rows(maxUsedRow)))
Else
    Set zTrim_Range = rng
End If

End Function