Multiple Lookup And Return All Values Concatenated With Delimiter

[Prabhu]

Hi,

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

Attached sample data for your reference.

Thanks,
Prabhu

[Excel Fox]

Use this

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

[aju.thomas]

Hi,

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

[Admin]

Hi

.. with one loop..

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

[Prabhu]

Thank you all!