Searching for a string of text from the main body and footnotes and copying it and its following # c-CodePudding

I have a large number of documents which I need to pull out file name references from, spread out across large blocks of text and footnotes.

I currently have a word VBA code that I think should search for a string (for example "This_") and then the following # of characters, and then paste them into a waiting excel sheet. I am struggling to get it to search both the footnotes and the main body of text.

I've been using the code below, but my work at the moment is making it do something weird. It will find the string I am searching for, but then it will copy from the start of the document the number of times the string has been found -- not the string and its subsequent text.

Any help would be appreciated in modifying this, I believe the issue will be coming from the first half of the 'return data to array section.

Option Explicit
Option 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\" & 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
ActiveDocument.StoryRanges(wdFootnotesStory).Select
With Selection.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
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

CodePudding user response：

Your code is a little confused as there is an unholy mix of Selection and Range. It is good practice to avoid using Selection as it is very rarely necessary to select anything when working in VBA.

VBA also has compiler constants that can be used to detect, among other things, whether code is being run on a Mac. Not sure if the Mac constant still works reliably as I no longer have one to test on.

    'Set parameters Change to your path and filename
    TgtFile = "File.xlsx"
    'This isn't necessary as there is a compiler constant that can be used to identify code is running on Mac
    '    If IsWindowsOS Then
    '        Tgt = "C:\users\user\" & TgtFile ' Windows OS
    '    Else
    '        Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
    '    End If
#If Mac Then
    Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
#Else
    Tgt = "C:\users\user\" & TgtFile ' Windows OS
#End If
    txt = InputBox("String to find")
    Lgth = InputBox("Length of string to return")
    Strt = Len(txt)


    'Return data to array
    'not necessary to select the story range
    'ActiveDocument.StoryRanges(wdFootnotesStory).Select
    Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
    With oRng
        With .Find
            .ClearFormatting
            .Forward = True
            .Text = txt
            .MatchCase = True
        End With
          
        While .Find.Execute
            'a match has been found and oRng redefined to the range of the match
            i = i   1
            .MoveEnd wdCharacter, Lgth
            arr(i) = .Text
            .Collapse wdCollapseEnd
            If i = ArrSize - 20 Then
                ArrSize = ArrSize   ArrIncrement
                ReDim Preserve arr(ArrSize)
            End If
        Wend
    End With

CodePudding user response：

For example, the following code returns both the found text and its page reference:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrFnd As String, StrOut As String
StrFnd = InputBox("String to find")
j = InputBox("String Length to find")
k = j - Len(StrFnd)
For i = 1 To k
  StrFnd = StrFnd & "^?"
Next
With ActiveDocument
  For i = 1 To 2 ' 1 = wdMainTextStory, 2 = wdFootnotesStory, 3 = wdEndnotesStory, etc.
    With .StoryRanges(i)
      With .Find
        .ClearFormatting
        .Text = StrFnd
        .Forward = True
        .Format = True
        .MatchWildcards = False
        .Wrap = wdFindStop
        .Replacement.Text = ""
      End With
      Do While .Find.Execute = True
        StrOut = StrOut & vbCr & .Text & vbTab
        Select Case .StoryType
          Case wdMainTextStory
            StrOut = StrOut & .Information(wdActiveEndAdjustedPageNumber)
          Case wdFootnotesStory
            StrOut = StrOut & .Duplicate.Footnotes(1).Reference.Information(wdActiveEndAdjustedPageNumber)
        End Select
      Loop
    End With
  Next
End With
MsgBox StrOut
Application.ScreenUpdating = True
End Sub

CodePudding user response：

This is an example of how to search multiple section of your document. Note that I'm using a Collection to gather up the items, so you don't have to keep increasing an array.

Option Explicit
Option Base 1

Sub test()
    Dim allFound As Collection
    Set allFound = TextFoundReport("This_", 10)
    
    Dim entry As Variant
    For Each entry In allFound
        Dim partType As Long
        Dim text As String
        Dim tokens() As String
        tokens = Split(entry, "|")
        '--- here is where you copy to an Excel sheet
        Debug.Print "Part type: " & tokens(0) & " - '" & tokens(1) & "'"
    Next entry
End Sub

Private Function TextFoundReport(ByVal text As String, _
                                 ByVal numberOfCharacters As Long) As Collection
    Dim whatWeFound As Collection
    Set whatWeFound = New Collection
    
    '--- create a list of the document parts to search
    Dim docParts As Variant
    docParts = Array(wdMainTextStory, wdFootnotesStory, wdEndnotesStory, wdCommentsStory)
    
    Dim foundRng As Range
    Dim docPart As Variant
    For Each docPart In docParts
        ActiveDocument.StoryRanges(docPart).Select
        '--- find all occurences in this part and add it to the collection
        '    the Item in the collection is the story type and the found text
        With Selection.Find
            .ClearFormatting
            .Forward = True
            .text = text
            .MatchCase = True
            .Execute
            Do While .found
                Set foundRng = ActiveDocument.Range _
                               (Start:=Selection.Range.Start   Len(text), _
                                End:=Selection.Range.End   numberOfCharacters)
                whatWeFound.Add CLng(docPart) & "|" & foundRng.text
                foundRng.Start = foundRng.End
                .Execute
            Loop
        End With
    Next docPart
    
    Set TextFoundReport = whatWeFound
End Function