Vlookup all matches - vba

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