Update:
I got it to work to a certain extent using the following code:
Sub ExtractData()
Application.ScreenUpdating = False
Dim wdApp As Object, wdDoc As Object, wdRng As Object, nwdDoc
Dim WkSht As Worksheet, LRow As Long, i As Long
Set WkSht = ThisWorkbook.Sheets("Sheet1")
LRow = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
Set wdApp = CreateObject("Word.Application")
If wdApp Is Nothing Then
MsgBox "Can't start Word.", vbExclamation
Exit Sub
End If
With WkSht
For i = 1 To LRow
If LCase(.Cells(i, 1).Text) = "true" Then
If Dir(.Cells(i, 2).Text, vbNormal) = "" Then
.Cells(i, 3).Value = "Please check File Location"
Else
Set wdDoc = wdApp.Documents.Open(Filename:=.Cells(i, 2).Text, _
AddToRecentFiles:=False, Visible:=False, ReadOnly:=False)
With wdDoc
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = 0 'wdFindStop
.Format = True
.Style = "Heading 2"
.MatchWildcards = False
.MatchCase = False
.Text = WkSht.Cells(i, 4).Value
.Replacement.Text = ""
.Execute
End With
If .Find.Found Then
Set wdRng = .Duplicate
wdRng.Collapse 0 'wdCollapseEnd
End If
.Start = wdRng.End
With .Find
.Style = "Heading 2"
.Text = ""
.Execute
End With
If .Find.Found Then
wdRng.End = .Duplicate.Start - 1
End If
If Not wdRng Is Nothing Then
With wdRng
While .Tables.Count > 0
.Tables(1).Delete
Wend
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = 0 'wdFindStop
.Format = False
.MatchWildcards = True
.Text = "[^13^l]{1,}"
.Replacement.Text = Chr(182)
.Execute Replace:=2 'wdReplaceAll
End With
Set nwdDoc = wdApp.Documents.Add
If Len(.Text) > 1 Then
.Copy
With nwdDoc
nwdDoc.Content.Paste
nwdDoc.SaveAs2 wdDoc.Path & "_Extract_" & wdDoc.Name
End With
Else
WkSht.Cells(i, 3).Value = "No Data"
End If
End With
Else
WkSht.Cells(i, 3).Value = "Not Found"
End If
End With
.Close SaveChanges:=False
End With
Set wdRng = Nothing
End If
End If
Next
End With
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing: Set nwdDoc = Nothing
Application.ScreenUpdating = True
End Sub
It perfectly does the job, however only for the first time the chapter I seek to extract. As I mentioned before, the chapter I try to get occurs several times in one source document. Any suggestions on how to change the code to make it copy all the sections that I need?
Thank you for any help!