VBA Code to VLookup Multiple Criteria & Remove Duplicates

Question

I have a VBA code that returns multiple values for a specific input given a set of criteria - How do I need to change the code to make it return multiple values ONLY if they are not unique to one another?

Function SingleCellExtract(LookupValue As String, LookupRange As Range, ColumnNumber As Integer, Char As String)
    Dim I As Long
    Dim xRet As String
    For I = 1 To LookupRange.Columns(1).Cells.Count
        If LookupRange.Cells(I, 1) = LookupValue Then
            If xRet = "" Then
                xRet = LookupRange.Cells(I, ColumnNumber) & Char
            Else
                xRet = xRet & "" & LookupRange.Cells(I, ColumnNumber) & Char
            End If
        End If
    Next
    SingleCellExtract = Left(xRet, Len(xRet) - 1)
End Function

Formula in cell:

=SingleCellExtract(Lookup Cell,Lookup Range,Column Index Number," & ")

enter image description here

In the above example, there are no duplicate values - However within my data, multiple names appear on the same date and thus I end up with the below. How do I get it to only return one name UNLESS they're unique to one another?

enter image description here

Answer 1

Add a check to the IF to ensure it is not there already:

Function SingleCellExtract(LookupValue As String, LookupRange As Range, ColumnNumber As Integer, Char As String)
    Dim I As Long
    Dim xRet As String
    For I = 1 To LookupRange.Columns(1).Cells.Count
        If LookupRange.Cells(I, 1) = LookupValue And InStr(Char & xRet, Char & LookupRange.Cells(I, ColumnNumber) & Char) = 0 Then
            If xRet = "" Then
                xRet = LookupRange.Cells(I, ColumnNumber) & Char
            Else
                xRet = xRet & "" & LookupRange.Cells(I, ColumnNumber) & Char
            End If

        End If
    Next
    SingleCellExtract = Left(xRet, Len(xRet) - len(char))
End Function