Loop to two columns and Concatenate values

[LalitPandey87]

Try this:
In my case data started from cell A1 and output data started from H1 so please change code accordingly if you need some changes

Option Explicit

Sub LMP_Test()

    Dim varArrData()                As Variant
    Dim varArrTemp()                As Variant
    Dim varArrTemp1()               As Variant
    Dim lngLoop                     As Long
    Dim lngIndex                    As Long
    Dim varVal1                     As Variant
    Dim varVal2                     As Variant
    Dim strOutput                   As String

    Const lngIDACol                 As Long = 2 'Change accordingly
    Const lngIDBCol                 As Long = 3 'Change accordingly
    Const lngStorCol                As Long = 4 'Change accordingly
    Const lngAvailCol               As Long = 5 'Change accordingly
    Const strDataStartCell          As String = "A1" 'Change accordingly
    Const strOutPutCell             As String = "H1" 'Change accordingly
    Const strSheetName              As String = "Sheet2" 'Change accordingly
    Const strConcatDelima           As String = " / " 'Change accordingly
    
    varArrData = ThisWorkbook.Worksheets(strSheetName).Range(strDataStartCell).CurrentRegion.Value
    varArrTemp = varArrData
    varArrTemp1 = varArrTemp
    For lngLoop = LBound(varArrTemp) + 1 To UBound(varArrTemp)
        'varVal1 = varArrTemp1(lngLoop, lngIDACol)
        varVal2 = varArrTemp1(lngLoop, lngIDBCol)
        strOutput = vbNullString
        strOutput = varArrTemp1(lngLoop, lngStorCol) & IIf(strOutput <> "", strConcatDelima, "") & strOutput
DoLoop:
        If varVal2 = "" Then GoTo ContinueForLoop
        lngIndex = GetArrayIndex(varVal2, varArrTemp1, lngIDACol)
        If lngIndex > 0 Then
            strOutput = varArrTemp1(lngIndex, lngStorCol) & IIf(strOutput <> "", strConcatDelima, "") & strOutput
            'varVal1 = varArrTemp1(lngIndex, lngIDACol)
            varVal2 = varArrTemp1(lngIndex, lngIDBCol)
        Else
            lngIndex = 0
            varVal1 = vbNullString
            varVal2 = vbNullString
        End If
        lngIndex = 0
        GoTo DoLoop
ContinueForLoop:
        varArrTemp1(lngLoop, lngAvailCol) = strOutput
        strOutput = vbNullString
    Next lngLoop
    With ThisWorkbook.Worksheets(strSheetName).Range(strOutPutCell)
        .Resize(, UBound(varArrTemp1, 2)).EntireColumn.Clear
        .Resize(UBound(varArrTemp1), UBound(varArrTemp1, 2)).Value = varArrTemp1
    End With
    
    Erase varArrData
    Erase varArrTemp
    Erase varArrTemp1
    lngLoop = Empty
    lngIndex = Empty
    varVal1 = Empty
    varVal2 = Empty
    strOutput = vbNullString

End Sub

Function GetArrayIndex(ByVal Val As Variant, ByVal varArr As Variant, Optional lngColNo As Long = 1) As Long

    Dim varDataArr              As Variant
    
    GetArrayIndex = 0
    On Error Resume Next
    With WorksheetFunction
        varDataArr = .Index(Application.Transpose(varArr), lngColNo)
        GetArrayIndex = .Match(Val, varDataArr, 0)
    End With
    On Error GoTo -1: On Error GoTo 0: Err.Clear
    
    varDataArr = Empty

End Function