Function listUnique(rng As Range) As Variant

        Dim val As String
        Dim elements() As String
        Dim elementSize As Integer
        Dim newElement As Boolean
        Dim i As Integer
        Dim distance As Integer
        Dim allocationChunk As Integer
        Dim uniqueSize As Integer
        Dim r As Long
        Dim lLastRow  As Long

        lLastRow = rng.End(xlDown).Row

        elementSize = 1
        unqueSize = 0

        distance = Range(Application.Caller.Address).Row - rng.Row

        If distance <> 0 Then
            If Cells(Range(Application.Caller.Address).Row - 1, Range(Application.Caller.Address).Column).Value = "" Then
                listUnique = ""
                Exit Function
            End If
        End If

        For r = 1 To lLastRow
            val = rng.Cells(r)
            If val <> "" Then
                newElement = True
                For i = 1 To elementSize - 1 Step 1
                    If elements(i - 1) = val Then
                        newElement = False
                        Exit For
                    End If
                Next i
                If newElement Then
                    uniqueSize = uniqueSize + 1
                    If uniqueSize >= elementSize Then
                        elementSize = elementSize * 2
                        ReDim Preserve elements(elementSize - 1)
                    End If
                    elements(uniqueSize - 1) = val
                End If
            End If
        Next


        If distance < uniqueSize Then
            listUnique = elements(distance)
        Else
            listUnique = ""
        End If
    End Function

Sub Zamena()
'aequit 24.02.2020
    Dim k&, l&, sl, s$
    Dim w As Worksheet
    Set w = Worksheets("Лист1")
    sl = Range("Словарь")
    For l = 2 To w.Cells(Rows.Count, 3).End(xlUp).Row
        s = w.Cells(l, 3)
        For k = 1 To UBound(sl)
            If InStr(1, w.Cells(l, 3), sl(k, 1)) > 0 Then
                s = Replace(s, sl(k, 1), sl(k, 2))
            End If
        Next k
        w.Cells(l, 4) = s
    Next l
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Call Zamena
    Application.ScreenUpdating = True
End Sub