Hi -

Give a try using FIND method;

Sub test()
On Error Resume Next
For Each r In Range("b8:b" & Cells(Rows.Count, 2).End(xlUp).Row)
    With Columns(1)
        Set c = .Find(r.Value, , , 2)
            If Not c Is Nothing Then
                f = c.Address
                Do
                    c.Value = Replace(c.Value, r.Value, r.Offset(, 1).Value)
                Set c = .FindNext(c)
                Loop Until f = c.Address
            End If
    End With
Next
End Sub
Regards,
event