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.