Option Explicit

Sub Perebor2() 'коллекция в словаре
    Dim a, i&, t, Dic As Object
    Dim el, elel, col, s$, c As Range
     
    a = Range("C2", Cells(Rows.Count, "A").End(xlUp)).Value
    Set Dic = CreateObject("Scripting.Dictionary")
     
    On Error Resume Next
    With Dic
        .CompareMode = 1
        For i = 1 To UBound(a)
            For Each t In Split(a(i, 3), "/")
            For Each el In Split(a(i, 3), "/")
            If Not .exists(t) Then .Add t, New Collection
            .Item(t).Add el, el
            Next
            Next
        Next
         
    End With
     
     For Each el In Dic.keys
        For Each col In Dic.Item(el)
        For Each elel In Dic.Item(col)
            Dic.Item(el).Add elel, elel
        Next
        Next
    Next
    On Error GoTo 0
     

For Each c In Selection.Cells
s = "": el = Trim(c)
    If Dic.exists(el) Then
        For Each col In Dic.Item(el)
            If col <> el Then s = s & "/" & col
        Next
    Else
        s = "/Нет замен"
    End If
        c.Next = Mid(s, 2)
Next
End Sub

Sub Perebor() 'коллекция в словаре
    Dim a, i&, t, Dic As Object
    Dim el, elel, col
    
    a = Range("C2", Cells(Rows.Count, "A").End(xlUp)).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    
    On Error Resume Next
    With Dic
        .CompareMode = 1
        For i = 1 To UBound(a)
            For Each t In Split(a(i, 3), "/")
            For Each el In Split(a(i, 3), "/")
            If Not .exists(t) Then .Add t, New Collection
            .Item(t).Add el, el
            Next
            Next
        Next
        
    End With
    
     For Each el In Dic.keys
        For Each col In Dic.Item(el)
        For Each elel In Dic.Item(col)
            Dic.Item(el).Add elel, elel
        Next
        Next
    Next
    On Error GoTo 0
    
    For Each el In Dic.keys
        Debug.Print "Артикул " & el
        For Each col In Dic.Item(el)
            If col <> el Then Debug.Print "Замена " & col
        Next
    Next

End Sub

    With Intersect(Columns(5), ActiveSheet.UsedRange)
    .Replace What:=vbLf & vbLf, Replacement:="'", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    End With