複数の基準をVLookupするためのVBAコード

Question

基準のセットで特定の入力に対して複数の値を返すVBAコードがあります。の場合のみ複数の値を返すようにコードを変更する必要がありますお互いにユニークではない？

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 

セルの数式：上記の例で

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

enter image description here

、重複する値がない - しかし私のデータの中に、複数の名前が同じ日付に表示されますので、私は終わります次のようにしてください。彼らが互いにユニークでないかぎり、どのようにして1つの名前だけを返すのですか？

enter image description here

Answer 1

がいないことを確認するためにIFにチェックを追加します。

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