Hi,
I'm a novice VBA user in need of some help. I'm trying to extract sections of text (paragraphs) bounded by a "start" word and "end" word from a 150+ page word (Office 2003) document to an excel document. The document has a cover sheet, table of contents the with the paragraphs in question in the middle of this document. The paragraphs are always bounded by the same "start" word string that's enumerated and the same "end" word.
START_1001
Blah
Blah
Blah
END_OF_PARAGRAPH
START_1002
Blah
Blah
Blah
END_OF_PARAGRAPH
I've attempted a section of code that somewhat works. The extract to excel part is troublesome as I can't seem to be able to index the row count properly not to have overlapping pasting of the paragraphs.
Also I'm having trouble keeping the loop going from paragraph to paragraph to the end of the word document before closing the excel doc. How do you know you're at the end of the document?
When the paragraph contains pictures in the word doc, when copied and pasted in excel the pictures are pasted on top of one another and on top of the text. Can this be corrected?
Thanks in advance for the help.
Option Explicit
Sub CopyRequirementsBetweenWords()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim Endofline As Object
Dim intRowCount As Integer
Dim LineCount As Integer
intRowCount = 1
Do Until ActiveDocument.Bookmarks("\Sel").Range.End = _
ActiveDocument.Bookmarks("\EndOfDoc").Range.End 'This is the "End of document" tag
With Selection.Find
.Text = "START_" 'This is the "Start" word for the search
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
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
If InStr(1, Selection.Text, "END_") Then Exit Do
Selection.MoveDown Unit:=wdLine, Extend:=wdExtend
LineCount = LineCount + 1
Loop
Selection.Copy
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("C:\temp\test1.xls").Sheets("Sheet1")
intRowCount = 1
End If
objSheet.Cells(intRowCount, 1).Select
objSheet.Paste
intRowCount = intRowCount + LineCount
Selection.MoveDown Unit:=wdLine, Count:=LineCount
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