在逗號分隔的列表中列出所有匹配的值？

Question

我有2個工作表：

工作表1：

Column C   Column D 
Supplier A   Fish 
Supplier A   Meat 
Supplier B   Bread 

工作表2：

Column C   Column F 
Supplier A 
Supplier B 

列F，我想創造所有匹配的供應商，該項目的列表。

因此，例如：

Column C   Column F 
Supplier A  Fish, Meat 
Supplier B  Bread 

我用下面的VBA函數：

Function SingleCellExtract(LookupValue As String, LookupRange As Range, LookupCol As Long, ReturnCol As Long, Char As String) 
'Updateby20150824 
    Dim varTMP As Variant, I As Long 
    varTMP = LookupRange 
    Dim xRet As String 
    For I = 1 To UBound(varTMP, 1) 
     If varTMP(I, LookupCol) = LookupValue Then 
      If xRet = "" Then 
       xRet = varTMP(I, ReturnCol) 
      Else 
       xRet = xRet & Char & varTMP(I, ReturnCol) 
      End If 
     End If 
    Next 
    SingleCellExtract = xRet 
End Function 

而這個公式F列

=SingleCellExtract(C1,Data!D:D,-1,",") 

的實際代碼工作正常，但我想根除需要在F列下方拖拽公式以產生結果。有沒有一種辦法可以提高代碼繞過該公式的需要，只是有這樣的事：

Range F1 = 'Comma Separated List' 
Next Cell in column F 
etc... 

Answer 1

，你可以使用宏和利用Dictionary對象

Sub Main() 
    Dim cell As Range 

    With CreateObject("Scripting.Dictionary") 
     For Each cell In Worksheets("Sheet1").Range("C1", Worksheets("Sheet1").Cells(Rows.count, "C").End(xlUp)) 
      .item(cell.Value) = .item(cell.Value) & cell.Offset(, 1).Value & "," 
     Next 
     For Each cell In Worksheets("Sheet2").Range("C1", Worksheets("Sheet2").Cells(Rows.count, "C").End(xlUp)) 
      MsgBox .item(cell.Value) 
      cell.Offset(, 3).Value = Left(.item(cell.Value), Len(.item(cell.Value)) - 1) 
     Next 
    End With 
End Sub