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 With
End Sub

Public 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 = True
Str1 = Text
Set 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)
Next
Telefon_sotov = rez

End Function