Sub замена2()

    Dim c As Range
    Dim firstrow As Long
    Dim a, i As Long

    With Sheets("орг")
        lastorg = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With

    With Sheets("Рай")
        a = .Cells(.Rows.Count, 1).End(xlUp).Row

        With .Range(.Cells(1, 1), .Cells(a, 1))

            For i = 2 To lastorg
                Set c = .Find(Sheets("орг").Cells(i, 2), LookIn:=xlValues)
                If Not c Is Nothing Then
                    firstrow = c.Row
                    Do
                        c.Value = Sheets("орг").Cells(i, 1).Value
                        Set c = .FindNext(c)
                    Loop While c.Row > firstrow
                End If
            Next i

        End With

    End With

End Sub

Dim dict
Dim i%, k%
dict = Sheets("орг").Range("a2:b" & Sheets("орг").Range("a65536").End(xlUp).Row)
For k = 2 To Sheets("Рай").Range("a65536").End(xlUp).Row
    For i = LBound(dict) To UBound(dict)
        If InStr(1, Sheets("Рай").Range("a" & k).Value, dict(i, 2)) > 0 Then
            Sheets("Рай").Range("a" & k).Value = dict(i, 1)
            Exit For
        End If
    Next i
Next k