Set bb = ThisWorkbook.Sheets("Данные" ;) 
Set d = ThisWorkbook.Sheets("Таблица соответствия" ;) 
lastrow = bb.Cells(Rows.Count, 4).End(xlUp).Row
lastrowd = d.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrowd
bb.Range(bb.Cells(1, 4), bb.Cells(lastrow, 5)).Replace what:=d.Cells(i, 1), Replacement:=d.Cells(i, 2), _
 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
 False, ReplaceFormat:=False
Next i

 aa.Range("$A$1:$ED$72991").AutoFilter Field:=52, Criteria1:= _
        "=*" & strin(i) & "*", Operator:=xlAnd
    With aa.Columns(52)
      Set c = .Find(strin(i))
      If Not c Is Nothing Then
        iadress = c.Address
        Do
        irow = c.Row
        aa.Cells(irow, 53) = 1
        Set c = .FindNext(c)
         Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With