Hi David,
I've actually worked out some fixes to my code issues. The loop works to continue to go through to the next paragraph, and I was able to delete the superimposed pictures.
The issue now is that if there is a table in the paragraph, the code enters the paragraph but gets stuck in an infinite loop right before entering the table to start copying - not sure how to fix this... Any thoughts?
Thanks!
Pat
Option Explicit
Sub CopyRequirementsBetweenWords()
' This macro copies requirements from a source document using a "Start" and "End" key word that defines a range
' and exports this selection to an Excel file.
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim Endofline As Object
Dim intRowCount As Integer
Dim LineCount As Integer
Dim StartText As String
Dim EndText As String
Dim OutputFileName As String
intRowCount = 1
'Define search parameters
StartText = InputBox("Please enter your Start word") 'This is the "Start" word for the search
EndText = InputBox("Please enter your End Word") 'This is the "End" word for the search
'Define output parameters
OutputFileName = InputBox("Please enter your Output File path, file name and extension (Ex: C:\Temp\Test.xls)")
Do Until ActiveDocument.Bookmarks("\Sel").Range.End = _
ActiveDocument.Bookmarks("\EndOfDoc").Range.End 'This is the "End of document" tag
With Selection.Find
.Text = StartText 'This is the "Start" word for the search from the Inputbox
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
LineCount = 1
End With
Selection.Find.Execute
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Do
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
'This is the "End" word for the search from the Inputbox
If InStr(1, Selection.Text, EndText) Then Exit Do
'This section does not work with Word tables...cursor does not enter the table to start copying
Selection.MoveDown Unit:=wdLine, Extend:=wdExtend
LineCount = LineCount + 1
Loop
Selection.Copy
LineCount = LineCount + 3
If objSheet Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
'Change the file path to match the location of your test.xls
Set objSheet = appExcel.workbooks.Open(OutputFileName).Sheets("Sheet1")
intRowCount = 1
End If
objSheet.Cells(intRowCount, 1).Select
objSheet.Paste
intRowCount = intRowCount + LineCount
Selection.MoveDown Unit:=wdLine, Count:=1
'Delete the newly pasted pictures in Excel
On Error Resume Next
objSheet.DrawingObjects.Visible = True '"objSheet" enables stuff to happen in Excel
objSheet.DrawingObjects.Delete
On Error GoTo 0
objSheet.Cells.ClearComments
Loop 'Loop to next requirement for copy and pasting into Excel document
If Not objSheet Is Nothing Then
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub