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

我有2个工作表：

工作表1：

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

工作表2：

 Column C Column F Supplier A Supplier B 

在FI列中，要创build与供应商匹配的所有项目的列表。

举个例子：

 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

你可以使用macros和利用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