Изъять из текста ссылки и изменить их

Sub Procedure_1()
    
    'Сначала данные поместим в массив, т.к.
    'если каждый раз обращаться к документу Word - это долго.
    'А затем сразу все данные поместим в новый документ.
    Dim sArray() As String
    
    Dim vArray As Variant
    Dim sLink As String
    Dim oNewDocument As Word.Document
    
    'Подготавливаем массив к работе.
    ReDim sArray(1 To 1)
    
    'Собираем текст в массив.
    With ActiveDocument.Content.Find
        '* - это специальный символ для поиска.
        'Она означает любое количество любых знаков.
        'Перед треугольными скобками стоят слеши, т.к.
        'треугольные скобки являются специальными символами при поиске в Word.
        .Text = "http://*\</a\>"
        '* будет работать, если MatchWildcards = True
        .MatchWildcards = True
        
        'Делаем действия, пока находится искомый текст.
        Do While .Execute = True
        
            'Для удобства написания кода, помещаем найденный фрагмент
            'в переменную.
            'Parent - это найденный фрагмент документа.
            sLink = .Parent.Text
            
            'Удаляем из строки </a>.
            sLink = Replace(sLink, "</a>", "")
            
            'Удаляем [url]http://.[/url]
            sLink = Replace(sLink, "http://", "")
            
            'Создаём массив на основе слешей.
            vArray = Split(sLink, "/")
            
            'Два последних элемента в этом массиве наши.
            'Помещаем эти два последних элемента в массив sArray.
            'Ubound - это порядковый номер последнего элемента в массиве.
            sArray(UBound(sArray)) = vArray(UBound(vArray)) & " - " & _
                vArray(UBound(vArray) - 1)
            
            'Добавляем в массив sArray строку для следующего найденного текста.
            ReDim Preserve sArray(1 To UBound(sArray) + 1)
            
        Loop
        
    End With
    
    
    'В массиве sArray будет лишняя строка. Удаляем её, чтобы не путаться.
    ReDim Preserve sArray(1 To UBound(sArray) - 1)
 
    'Создаём новый документ, к которому будем обращаться через переменную oNewDocument.
    Set oNewDocument = Documents.Add
    
    'Выводим массив в новый документ Word.
    'С помощью Join преобразуем массив в строку.
    'Chr(13) - это знак абзаца.
    oNewDocument.Range.Text = Join(sArray, Chr(13))
    
    'Сообщение, что работа кода завершена.
    MsgBox "Работа кода завершена!", vbInformation
 
End Sub