VBA Code to Find TEXT and Following Text in Body and Text

[RMullen27]

Hi,

I currently have a Word VBA code which searches a word document for text, then finds the following # of characters and pastes them into a waiting excel sheet. Unfortunately, it currently only searches the main body of text, when I will need it to search both the main body and the footnotes.

What would I need to change on this to achieve it? If possible, it would also be useful to copy the search text and the following string of characters. This isn't key, as I can solve this with the excel sheet, but it would be nice to not have to sort it.

Any advice would be greatly appreciated.

Option ExplicitOption Base 1
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)


'Set parameters Change to your path and filename
TgtFile = "File.xlsx"
If IsWindowsOS Then
Tgt = "C:\Users\user\Documents\" & TgtFile ' Windows OS
Else
Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
End If
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)


'Return data to array
With Selection
.HomeKey unit:=wdStory
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
End With
ReDim Preserve arr(i)


'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.workbooks.Open(Tgt)
Set mySh = myWB.sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.transpose(arr)
End With


'Tidy up
myWB.Close True
myObj.Quit
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub


Public Function IsWindowsOS() As Boolean
If Application.System.OperatingSystem Like "*Win*" Then
IsWindowsOS = True
Else
IsWindowsOS = False
End If
End Function

[RMullen27]

I have found a way to search the footnotes by replacing the first section of 'Return data to array with the following:

ActiveDocument.StoryRanges(wdFootnotesStory).Select
With Selection.Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
.Execute

However, now, while it searches for the text and finds them, it seems to copy random bits of the main body of text. Can anyone understand why this would be the case?

[RMullen27]

I have found a way to search the footnotes by replacing the first section of 'Return data to array with the following:

ActiveDocument.StoryRanges(wdFootnotesStory).Select
With Selection.Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
.Execute

However, now, while it searches for the text and finds them, it seems to copy random bits of the main body of text. Can anyone understand why this would be the case?

Okay so there is method to the madness of returned results. The string that it returns is actually taken from the start of the document. So if I have found a string 10 times, and I want the next four characters, it will find the next four characters from the first page of the document.

This has stumped me. I cannot figure out how to get the found code to pick up from the footnotes.

Although I do think I have figured out how to also pick out the initial string (by removing Strt.