Consulting

Results 1 to 10 of 10

Thread: Extracting text from Word to Excel between "start" and "end" words

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #1
    VBAX Newbie
    Joined
    Sep 2010
    Posts
    3
    Location

    Extracting text from Word to Excel between "start" and "end" words

    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
    Last edited by Aussiebear; 04-19-2023 at 08:22 PM. Reason: Adjusted the code tags

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •