Concatenate data from cells by values from two columns

Check this

Sub INTERST()

    Dim D As Object
    Dim i As Long
            
            Set D = CreateObject("scripting.dictionary")

'Filling Dictionary object with unique values and their Data
With Sheets("Data")
    For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
        If Not D.exists(CStr(Cells(i, 2).Value)) Then
            D.Add CStr(Cells(i, 2).Value), CStr(Cells(i, 3).Value) & "-" & Cells(i, 4).Value
    Else
        D.Item(CStr(Cells(i, 2).Value)) = D.Item(CStr(Cells(i, 2).Value)) & "," & Cells(i, 3).Value & "-" & Cells(i, 4).Value
       End If
    Next
End With
    
'Now Retrieval
With Sheets("Result")
        For j = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
        
                Tmp = Split(D.Item(CStr(.Cells(j, 1).Value)), ",")  'Get Each dictionary value Data and split it with ","
                    If InStr(.Cells(j, 2), "|") > 0 Then
                        Tmp2 = Split(.Cells(j, 2), "|")                        'Split second column Text for looping array Ex:2|4
                            LT = Tmp2(0)                                        'Lower bound of array
                                Ht = Tmp2(1)                                    'Higer bound of array
                                    For k = LT - 1 To Ht - 1
                                            Txt = Txt & Split(Tmp(k), "-")(1)
                                    Next
                                              .Cells(j, 4) = "(" & Txt & ") (" & Application.WorksheetFunction.VLookup(.Cells(j, 1).Value, Sheets("data").Range("F:G"), 2, 0) & " " & .Cells(j, 2).Value & ")"
                                        Else
                                                .Cells(j, 4) = "(" & Split(Tmp(0), "-")(1) & ") (" & Application.WorksheetFunction.VLookup(.Cells(j, 1).Value, Sheets("data").Range("F:G"), 2, 0) & " " & .Cells(j, 2).Value & ")"
                                    
                End If
                Txt = ""
        Next
    
    End With

MsgBox "Hey I have done my work"

End Sub

'Made by :- Mandeep baluja
'https://www.facebook.com/groups/825221420889809/
'https://www.linkedin.com/in/mandeep-baluja-b777bb88
Add Reputation if it helped

Maybe :

Sub Test()
  Dim coll As New Collection, arr, i As Long, j As Long, k1 As Long, k2 As Long, v

  arr = Sheets("Data").Range("A1").CurrentRegion.Value
  For i = 2 To UBound(arr, 1)
      coll.Add key:=arr(i, 2) & Chr$(2) & arr(i, 3), Item:=arr(i, 4)
  Next i

  arr = Sheets("Data").Range("F1").CurrentRegion.Value
  For i = 2 To UBound(arr, 1)
      coll.Add key:=CStr(arr(i, 1)), Item:=arr(i, 2)
  Next i

  With Sheets("Result").Range("F1").CurrentRegion
    arr = .Value
    For i = 2 To UBound(arr, 1)
        arr(i, 3) = ""
        v = Split(arr(i, 2), "|"): k1 = CLng(v(0)): If UBound(v) = 0 Then k2 = k1 Else k2 = v(1)
        On Error Resume Next
           For j = k1 To k2
               arr(i, 3) = arr(i, 3) & Space$(1) & coll(arr(i, 1) & Chr$(2) & j)
           Next j
           arr(i, 3) = "(" & arr(i, 3) & " )     < " & coll(CStr(arr(i, 1))) & Space$(1) & arr(i, 2) & " >"
        On Error GoTo 0
    Next i
    .Value = arr
  End With
End Sub

You are welcome, it's my pleasure.


Regards

Don't have time for more but to give you an idea how it works.
On sheet Result select f.i. range H2 and run below code.

Sub tst()
    f = InStr(1, ActiveCell, "<", vbTextCompare)
    ff = InStrRev(ActiveCell, ">", , vbTextCompare)
    fff = (ff - 1) - (f + 1)
    ActiveCell.Characters(f, fff).Font.Name = "Arial"
End Sub

Select other cell and run code again.

Tried it with over 10,000 rows and it took about 1 sec. so I don't think that 's such a big disaster no ?

Sub tst2()
    t = Timer
    Application.ScreenUpdating = False
    For i = 2 To Range("H" & Rows.Count).End(xlUp).Row
        f = InStr(1, Cells(i, 8), "<", vbTextCompare)
        Cells(i, 8).Characters(f).Font.Name = "Arial"
    Next
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub

You're welcome and thanks for the rep