Vlookup all matches

Question

How to vlookup all matches

If i have

ID    String
1     xxx
2     yyy
1     zzz
3     ooo
1     ppp
1     zzz

I need vlookup ID=1 anf get in one cell

xxx
zzz
ppp

Application.Vlookup(1;A2:B7;2;False)

Found only first occurents

How to find all unique matches?

Answer 1

You need to create a UDF to do this. Please copy and paste the following code. (Remember to to early binding for Dictionary Object -- check Microsoft Scripting Runtime in Tool — Reference dialog in VBE. You can find some detailed explanation and screenshots in http://www.cnblogs.com/hejing195/p/8198584.html )

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

Answer 2

For the given problem, the VLOOKUP method will not help. So you have to play with ROW and INDEX array formulas.

Using the record macro function:

' Apply the formula to retrieve the matching value
Selection.FormulaArray = _
    "=INDEX(R2C1:R7C2,SMALL(IF(R2C1:R7C1=1,ROW(R2C1:R7C1)),ROW(R[-9]))-1,2)"
Selection.AutoFill Destination:=Range("A10:A13"), Type:=xlFillDefault
' Get the unique values by removing the duplicate
ActiveSheet.Range("$A$10:$A$13").RemoveDuplicates Columns:=1, Header:=xlNo

Using the VBA code

findValue = 1
totalRows = Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
j = 1
For i = 2 To totalRows
    If Cells(i, 1).Value = findValue Then
        ' Fill in the D:D range
        Cells(j, 4).Value = Cells(i, 2).Value
        j = j + 1
    End If
Next
ActiveSheet.Range("D:D").RemoveDuplicates Columns:=1, Header:=xlNo