Option Explicit
Sub TACH()
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim i&, j&, Lr&, t&
Dim Arr(), S, tmp, Temp
Lr = Sheet1.Cells(Rows.Count, 1).End(3).Row
Arr = Sheet1.Range("A2:B" & Lr).Value
ReDim KQ(1 To UBound(Arr), 1 To 1)
For i = 1 To UBound(Arr)
tmp = Trim(Arr(i, 2))
If Not dic.exists(tmp) Then dic.Item(tmp) = Arr(i, 2)
Next i
For i = 1 To UBound(Arr)
tmp = Trim(Arr(i, 1))
Temp = Split(tmp, " ")
For j = 0 To UBound(Temp)
If dic.exists(Temp(j)) Then KQ(i, 1) = dic.Item(Temp(j))
Next j
Next i
Sheet1.[E2].Resize(i, 1) = KQ
End Sub
