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

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

1 个答案: