Найти определенное слово в тексте и записать все найденные значения в другой файл - VB - Ответ 6228679

Option Explicit
'
'(c) FelixMacintosh ,2014
'Поиск телефона
'
Dim sFile$, fso As Object
Sub i()
    Dim s$
    s = s & "//Есть txt файл со списком телефонов, где записаны телефон 8919... и т.д.//"
    s = s & "//Ищем слово ''телефон'' в тексте, далее смотрим значение текста (номер телефона) после слова телефон ''+7''"
    s = s & "//then ставлю счетчик i=i+1 все вычитывает правильно"
    s = s & "//телефон неизвестен +7(800)123 456 78"
    s = s & "//если ставлю res = Mid(Stri$, 43, 12) вытаскивает(записывает) только один телефон и все"
    s = s & "//как сделать чтоб вытащил(записал) ВСЕ номера из списка?"
    s = s & "//телефон сбербанка +7(800)555 555 50"
    fso.CreateTextFile(sFile).Write Replace(s, "//", vbCrLf)
End Sub
 
Private Sub Form_Activate()
    Dim TempStr$, Result$, f&, key$, lm&, i1&, Ab$, j$()
    ChDir App.Path 'Заходим в свою папку
    sFile = InputBox("Введите имя файла" & _
    vbCrLf & "..можете согласится и нажать OK", , "номера телефонов.tel")
    If Len(sFile) Then Else Exit Sub 'Нажата Cancel
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(sFile) Then Else i 'Создаём тестовый файл
    '=================================
    TempStr = fso.OpenTextFile(sFile).ReadAll
    key = "+7?###?### ### ##": lm = Len(key)
    Call cls: Print "Найденные телефоны:"
    For f = 1 To Len(TempStr) - lm + 1
        Result = Mid$(TempStr, f, lm)
        If Result Like key Then
            Ab = Split(TempStr, Result, 2)(0)
            j = Split(Ab, vbCrLf): Ab = j(UBound(j))
            Print Ab & vbTab & Result
        End If
    Next
End Sub