Sub iPoiskReplace()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim arr
Dim j As Integer
    iLastRow = Cells(Rows.Count, "F").End(xlUp).Row
    Range("G2:G" & iLastRow).ClearContents
    Range("G2:G" & iLastRow).NumberFormat = "@"
  For i = 2 To iLastRow
    arr = Split(WorksheetFunction.Trim(Cells(i, "F")), " ")
    For j = 0 To UBound(arr)
      Set FoundCell = Columns("A:D").Find(arr(j), , xlValues, xlPart)
      If Not FoundCell Is Nothing Then
        Cells(i, "G") = Cells(i, "G") & Cells(1, FoundCell.Column) & " "
      Else
        Cells(i, "G") = Cells(i, "G") & arr(j) & " "
      End If
    Next
  Next
End Sub