RMullen27
02-16-2022, 09:52 AM
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
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