Sub Telefon()    Dim arr(), arr2(), Dic As Object, i&, iKey$    With Worksheets("Лист1")            arr = .Range("H2:L" & .Cells(.Rows.Count, "K").End(xlUp).Row).Value        Set Dic = CreateObject("Scripting.Dictionary"): Dic.comparemode = 1        For i = 1 To UBound(arr)            Dic.Item(Trim(arr(i, 1)) & "|" & Trim(arr(i, 2)) & "|" & Trim(arr(i, 3))) = Trim(arr(i, 4))        Next                arr = .Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value        ReDim arr2(1 To UBound(arr, 1), 1 To 1)        For i = 1 To UBound(arr)            iKey = Trim(arr(i, 1)) & "|" & Trim(arr(i, 2)) & "|" & Trim(arr(i, 3))            If Dic.exists(iKey) Then                        arr2(i, 1) = Telefon_sotov(Dic.Item(iKey))            End If        Next                .[F2].Resize(UBound(arr2), 1) = arr2    End WithEnd SubPublic Function Telefon_sotov(Text As String)Set objRegExp = CreateObject("VBScript.RegExp")objRegExp.Pattern = "\+7\s\d{3}\s\d{3}-\d{2}-\d{2}"objRegExp.Global = TrueStr1 = TextSet objMatches = objRegExp.Execute(Str1)For i = 0 To objMatches.Count - 1    If rez = "" Then rez = objMatches.Item(i) Else rez = rez & Chr(10) & objMatches.Item(i)NextTelefon_sotov = rezEnd Function

Sub test()
Dim arr(), i&, itxt
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
With Лист1
    arr = .Range(.[E2], .[F2].End(xlDown)).Value
    For i = 1 To UBound(arr)
        dic.Item(CStr(arr(i, 1))) = arr(i, 2)
    Next i
    Erase arr
    arr = .Range(.[C2], .[A2].End(xlDown)).Value
    For i = 1 To UBound(arr)
        itxt = Trim(arr(i, 1)) & " " & Trim(arr(i, 2))
        If dic.exists(itxt) Then arr(i, 3) = dic.Item(itxt)
    Next i
    .Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End With
End Sub

Sub Telefon()
With Worksheets("Лист1")
    arr = .Range("H2:L" & .Cells(.Rows.Count, "L").End(xlUp).Row).Value
    Set dic = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    For I = 1 To UBound(arr)
        iKey = Trim(arr(I, 1)) & Trim(arr(I, 2)) & Trim(arr(I, 3)) & CStr(arr(I, 4))
        dic.Add iKey, CStr(arr(I, 5))
    Next
    Erase arr
    arr = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
    For I = 1 To UBound(arr)
        iKey = Trim(arr(I, 1)) & Trim(arr(I, 2)) & Trim(arr(I, 3)) & CStr(arr(I, 4))
        If dic.Exists(iKey) Then arr(I, 6) = dic(iKey)
    Next
    .Range("B2:E").Resize(UBound(arr), 6) = arr
End With
End Sub

Sub test() 
Dim arr(), i&, itxt 
Dim dic As Object 
Set dic = CreateObject("Scripting.Dictionary") 
With Лист1 
   arr = .Range(.[e2], .[f2].End(xlDown)).Value 
   For i = 1 To UBound(arr) 
       dic.Item(CStr(arr(i, 1))) = arr(i, 2) 
   Next i 
   Erase arr 
   arr = .Range(.[c2], .[a2].End(xlDown)).Value 
   For i = 1 To UBound(arr) 
       itxt = Trim(arr(i, 1)) & " " & Trim(arr(i, 2)) 
       If dic.exists(itxt) Then arr(i, 3) = dic.Item(itxt) 
   Next i 
   .Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr 
End With 
End Sub 

Sub test() 
Dim arr(), i&, itxt 
Dim dic As Object 
Set dic = CreateObject("Scripting.Dictionary") 
With Лист1 
   arr = .Range(.[h2], .[i2], .[j2], .[k2], .[l2].End(xlDown)).Value 
   For i = 1 To UBound(arr) 
       dic.Item(CStr(arr(i, 1))) = arr(i, 2) 
   Next i 
   Erase arr 
   arr = .Range(.[f2], .[a2], .[b2], .[c2], .[d2].End(xlDown)).Value 
   For i = 1 To UBound(arr) 
       itxt = Trim(arr(i, 1)) & " " & Trim(arr(i, 2)) 
       If dic.exists(itxt) Then arr(i, 3) = dic.Item(itxt) 
   Next i 
   .Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr 
End With 
End Sub