Word VBA to Extract ALL Sentences Containing Citations to Excel

[cloop]

Hello,

I need a VBA (Word) loop to evaluate every sentence in an open word document for a citation, designated as "[*]" (Superscript)

If found, copy the entire sentence to Excel (including the citation), with each instance being placed in an incremental row. Ex: A1, A2, A3...

I have come across several keyword extraction scripts, however I have not been able to get them to work, presumably because the citation occurs outside of the range of the sentence, and therefore is not found.

I have a moderate knowledge of VBA in Excel, so I can make minor adjustments on the receiving end, however I am not familiar enough with Word ranges, etc to evaluate and loop the word portion of this request.

Thanks in advance,
Casey

[gmayor]

[*] is not the usual format for a Word citation, but assuming the * is a wildcard character, the following macro will look for text in that format (superscripted) in the document and write the sentence that contains it to an Excel workbook, which it will create if not present. If you want it to create the folder also, investigate the CreateFolders function from my web site VBA examples. Change the path and workbookname as appropriate.

Option Explicit

Sub ExtractSentences()
Dim oRng As Range
Dim xlApp As Object
Dim xlBook As Object
Dim NextRow As Long
Const strWorkbookname As String = "C:\Path\WorkbookName.xlsx" 'The folder must exist
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    If FileExists(strWorkbookname) Then
        Set xlBook = xlApp.workbooks.Open(Filename:=strWorkbookname)
    Else
        Set xlBook = xlApp.workbooks.Add
        xlBook.Sheets(1).Cells(1, 1).Value = "Extracted Sentences"
        xlBook.SaveAs strWorkbookname
    End If
    xlApp.Visible = True

    Set oRng = ActiveDocument.Range
    With oRng.Find
        .Font.Superscript = True
        Do While .Execute(FindText:="\[*\]", MatchWildcards:=True)
            NextRow = xlBook.Sheets(1).Range("A" & xlBook.Sheets(1).Rows.Count).End(-4162).Row + 1
            oRng.Expand wdSentence
            xlBook.Sheets(1).Cells(NextRow, 1).Value = Trim(oRng.Text)
            xlBook.Save
            oRng.Collapse 0
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
    Set xlApp = Nothing
    Set xlBook = Nothing
    Exit Sub
End Sub

Private Function FileExists(strFullName As String) As Boolean
'Graham Mayor
'strFullName is the name with path of the file to check
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(strFullName) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

[cloop]

gmayor,

Very well done, thank you.