Excel Use Word to Find Text and return the following 10 characters

Hi

I have a Macro which will open a word document, find some text and then replace it.

I would like to change it so that it finds the text and then simply record that text with the next 10 characters in a spreadsheet.

I want to find all 0845 numbers in word documents on a network drive and find out what the rest of the telephone number is.

This is my current code which is performing the find text count and then only making changes to the document if the text is found.

Sub Open_Word_Document()

'Opens a Word Document from Excel

'set the variables
Dim ws As Worksheet
Dim objWord As Object
Dim New_Folder As String
Dim wdDoc As Object
Dim y As Integer
Dim n As Integer
Dim Doc_Count As Integer
Dim Filepath As String
Const wdReplaceAll = 2 ' replace all won't work without this
Dim from_text As String, to_text As String

' define the current worksheet
Set ws = ActiveWorkbook.Sheets("Filepaths")
' define variables
New_Folder = Range("New_Folder")
from_text = Range("Text_Find")
to_text = Range("Text_Replace")
Doc_Count = Range("Doc_Count")

' open word
Set objWord = CreateObject("Word.Application")
objWord.Visible = True

'start rountine and open the word document
For n = 1 To Doc_Count
Filepath = ws.Cells(1 + n, 2) ' filepath of the document we want to update
Set wdDoc = objWord.Documents.Open(Filepath) ' open the word document

' remove editing restrictions and flag if document is password protected
On Error Resume Next
    wdDoc.Unprotect  ' remove editing restrictions
        If Err > 0 Then ' loop through in case the document isn't protected
        Else
            wdDoc.Unprotect
        End If
        
    If Err = 5485 Then ' document is password protected
        ws.Cells(n + 1, 3) = "Can't change as document is password protected"
    Else ' perform the count of the find text - could have this as a separate routine
        y = 0 ' reset y to zero & perform word count
                
        ' search document
        With wdDoc.Content.Find
            Do While .Execute(FindText:=from_text, Forward:=True, Format:=True, _
                MatchWholeWord:=True) = True
            y = y + 1
            Loop
        End With
        
        ' search text boxes
        For Each myStoryRange In wdDoc.StoryRanges
                With myStoryRange.Find
                    Do While .Execute(FindText:=from_text, Forward:=True, Format:=True, _
                        MatchWholeWord:=True) = True
                    y = y + 1
                    Loop
                End With
            Do While Not (myStoryRange.NextStoryRange Is Nothing)
                Set myStoryRange = myStoryRange.NextStoryRange
                With myStoryRange.Find
                    Do While .Execute(FindText:=from_text, Forward:=True, Format:=True, _
                        MatchWholeWord:=True) = True
                    y = y + 1
                    Loop
                End With
            Loop
        Next myStoryRange

Moderator's note: Please take the time to review our rules. There aren't many, and they are all important. Rule #3 requires code tags. I have added them for you this time because you are a new member. --6StringJazzer