Search and Extract text from a list of description

Why Federal Express; FedEx in row 3?

Sub test()
    Dim a, i As Long, myPtn As String, m As Object, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("client")
        myPtn = Join(Application.Transpose(.Range("a2", .Range("a" & Rows.Count).End(xlUp)).Value), Chr(2))
    End With
    With Cells(1).CurrentRegion.Resize(, 2)
        .Columns(2).Offset(1).ClearContents
        a = .Value
        With CreateObject("VBScript.RegExp")
            .Global = True
            .Pattern = "([$()^\-|{}\[\]+*?.])"
            myPtn = Replace(.Replace(myPtn, "\$1"), Chr(2), "|")
            .Pattern = "\b(" & myPtn & ")\b"
            For i = 2 To UBound(a, 1)
                For Each m In .Execute(a(i, 1))
                    dic(m.Value) = Empty
                Next
                If dic.Count Then a(i, 2) = Join(dic.keys, "; ")
                dic.RemoveAll
            Next
        End With
        .Value = a
    End With
End Sub