Multiple Lookup And Return All Values Concatenated With Delimiter

Hi,

I need to compare tow columns and get the matched result in single cell.

Attached sample data for your reference.

Thanks,
Prabhu

Use this

Code:

---

Sub SMC()

    Dim rngSource As Range
    Dim var As Variant, varOut As Variant, varOutCombin As Variant
    Dim lngRow As Long, lngCol As Long
    Dim objDic As Object
    Set objDic = CreateObject("Scripting.Dictionary")
    Set rngSource = Range("A2:B14")
    var = rngSource.Value2
    For lngRow = LBound(var) + 1 To UBound(var)
        For lngCol = LBound(var, 2) To UBound(var, 2)
            If IsEmpty(var(lngRow, lngCol)) Then
                var(lngRow, lngCol) = var(lngRow - 1, lngCol)
            Else
                If lngCol = LBound(var, 2) Then
                    objDic.Item(var(lngRow, lngCol)) = 0
                End If
            End If
        Next lngCol
    Next lngRow
    varOut = objDic.Keys
    ReDim varOutCombin(1 To objDic.Count)
    For lngRow = LBound(var) + 1 To UBound(var)
        For lngCol = LBound(varOut) To UBound(varOut)
            If var(lngRow, 1) = varOut(lngCol) Then
                If IsEmpty(varOutCombin(lngCol + 1)) Then
                    varOutCombin(lngCol + 1) = var(lngRow, 2)
                Else
                    varOutCombin(lngCol + 1) = varOutCombin(lngCol + 1) & "," & var(lngRow, 2)
                End If
            End If
        Next lngCol
    Next lngRow
    rngSource.Offset(1).ClearContents
    rngSource(2, 1).Resize(5).Value = Application.Transpose(varOut)
    rngSource(2, 2).Resize(5).Value = Application.Transpose(varOutCombin)
   
End Sub

---

Hi,

I am not sure a formula can do your work, so i have created a macro to do it.

Hi

.. with one loop..

Code:

---

Sub kTest()
   
    Dim k, i As Long, sKey  As String, sItems As String, d As Object
   
    k = Range("a2").CurrentRegion.Resize(, 2).Value2
   
    Set d = CreateObject("scripting.dictionary")
        d.comparemode = 1
   
    For i = 2 To UBound(k, 1)
        If LenB(k(i, 1)) Then sKey = k(i, 1)
        If LenB(sKey) Then
            sItems = d.Item(sKey)
            If LenB(sItems) Then
                d.Item(sKey) = sItems & "," & k(i, 2)
            Else
                d.Item(sKey) = k(i, 2)
            End If
        End If
    Next
   
    With Range("d10")
        .Resize(d.Count) = Application.Transpose(d.keys)
        .Offset(, 1).Resize(d.Count) = Application.Transpose(d.items)
    End With
   
End Sub

---

Thank you all!