Sub T()
Dim strS As String, strO As String, strI As String, intI As Integer, lngI As Long
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.Pattern = "\+7\s?[(]?\d{3}[)]?\s?\d{3}-\d{2}-\d{2}"
objRegExp.Global = True
    'чистим столбец F
    Range("F2").CurrentRegion.ClearContents
    'циклом бегаем по всем ИНН из столбца А и находим их значения в столбце H
    'забираем значения из столбца К (телефоны) по найденной строке на обработку
    For lngI = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        strI = Range("A" & lngI).Value
        'если значение ИНН не нашли в перечне - ругаемся и выходим
        If Range("H1").CurrentRegion.Find(strI) Is Nothing Then
            MsgBox ("Значение ИНН " & Range("A" & lngI) & " нет в перечне ИНН")
            Exit Sub
        End If
        'меняем в найденных телефонах все скобки на ничего
        strS = Range("H1").CurrentRegion.Find(strI).Offset(0, 3).Value
        strS = Replace(strS, "(", "")
        strS = Replace(strS, ")", "")
        'по заданному шаблону проверяем номера телефонов. Если встречается код 455, 499 - не пишем в итоговую строку
        Set objMatches = objRegExp.Execute(strS)
        For intI = 0 To objMatches.Count - 1
            If InStr(1, objMatches.Item(intI), "+7 495") = 0 And InStr(1, objMatches.Item(intI), "+7 499") = 0 Then
                strO = strO & objMatches.Item(intI) & ",|"
            End If
        Next intI
        'если итоговая строка не пустая, пишем в столбец F значения теелфонов, разделенные запятыми и переносом
        If Not strO = "" Then
            strO = Left(strO, Len(strO) - 2)
            Range("F" & lngI) = Replace(strO, "|", Chr(10))
            strO = ""
        End If
    Next lngI 'и так бегаем циклом пока в столбце А не кончатся данные
End Sub