Option Explicit
Option Private Module
'===========================================================================================
Sub ЗаменитьВыделенноеПоСписку()
Dim arr, rng As Range, choose As Byte, ByPart As Boolean, NoCase As Boolean
Const shName$ = "соответствия"


Set rng = Selection
choose = MsgBox("Проверяем ячейку Целиком [ДА] или по её Части [НЕТ]?", vbYesNoCancel + vbQuestion + vbDefaultButton1, "ВЫБОР СРАВНЕНИЯ")
If choose = vbCancel Then Exit Sub
If choose = vbNo Then ByPart = True

choose = MsgBox("Проверяем данные с учётом регистра или нет?", vbYesNoCancel + vbQuestion + vbDefaultButton1, "ВЫБОР СРАВНЕНИЯ")
If choose = vbCancel Then Exit Sub
If choose = vbNo Then NoCase = True

Application.ScreenUpdating = False

    With Worksheets(shName)
        If Len(.Cells(1, 1)) < 1 Or Len(.Cells(1, 2)) < 1 Then MsgBox "Списки замены (было/стало) должны располагаться в первых 2х столбцах листа «" & shName & ", начиная с 1ой строки!", vbCritical, "ОШИБКА СПИСКОВ ЗАМЕНЫ": GoTo fin
        arr = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row)
    End With

Call ReplaceByList_InRange(rng, arr, ByPart, NoCase)
fin: Application.ScreenUpdating = True
End Sub
'-------------------------------------------------------------------------------------------
Function ReplaceByList_InRange(rng As Range, arr2xFR, Optional ByPart As Boolean, Optional NoCase As Boolean) As Boolean
Dim x, i&

    If ByPart Then
        For i = 1 To UBound(arr2xFR, 1)
            rng.Replace arr2xFR(i, 1), arr2xFR(i, 2), 2, xlByRows, Not (NoCase), False, False
        Next i
    Else
        For i = 1 To UBound(arr2xFR, 1)
            rng.Replace arr2xFR(i, 1), arr2xFR(i, 2), 1, xlByRows, Not (NoCase), False, False
        Next i
    End If

ReplaceByList_InRange = True
End Function
'===========================================================================================
'Selection.Replace What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ' макрорекордер