Opening Word document, copying specific text, paste into word document

Question

I have an Excel Worksheet, with a list of different Headings. These Headings are also in a Word Document, but in the Word Document, there is unnecessary information as well. What I am trying to do and sorry for my coding I am just learning is:

1. To open the Word Document from Excel
2. Scan the Excel Worksheet Column A for all Heading
3. Compare the Headings with the Headings in The Word Document
4. If they are the same, then copy them in another Word Document (the complete paragraph until the next Heading1)
5. If they are not the same, they can be ignored
6. This should then be a loop, so it scans it until all Heading from Excel are find and copyied

What I tried so far is this:

Sub Search_Word_Document()

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("file:///J:\Test.docx")

With ActiveDocument.Content.Find
FindWord = Columns("A:A").Value
With .Style = ActiveDocument.Styles("Heading 1")


wrdApp.Selection.WholeStory
wrdApp.Selection.Find.ClearFormatting
With wrdApp.Selection.Find

.Text = FindWord
.Forward = True
.Style = ActiveDocument.Styles("Heading1")
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False


End With

End Sub

Its opening the document fine, but then the finding for the text out of the columns is absolutely not working as well as finding the Headings. Thank you for your help.

Answer 1

In the meantime, I came up with this:

Sub Align_With_Word_Document()
    Dim wordApp As Word.Application
    Set wordApp = GetObject("", "Word.Application")
    wordApp.Visible = True

    Dim newWordDoc As Word.Document
    Set newWordDoc = wordApp.Documents.Add

    Dim wordDoc As Word.Document
    Set wordDoc = wordApp.Documents.Open("file:///J:\Test.docx")
    wordDoc.Activate


    Dim headings As Collection
    Set headings = wordDoc.Application.Run("NewMacros.extractHeadings")

    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")

    Dim counter As Long
    counter = 1
    Dim currentHeading As Long
    currentHeading = 1
    Do While ws.Cells(counter, 1) <> ""
        Dim ExpectedHeading As String
        ExpectedHeading = ws.Cells(counter, 1)

        Dim lookupHeading As Long
        lookupHeading = currentHeading
        Do While lookupHeading <= headings.Count
            If InStr(1, headings(lookupHeading).Text, ExpectedHeading, vbTextCompare) = 1 Then
                Exit Do
            End If
            lookupHeading = lookupHeading + 1
        Loop

        If lookupHeading <= headings.Count Then
            currentHeading = lookupHeading
            Debug.Print "Found heading '" & ExpectedHeading & "'" & " at index " & currentHeading
            headings(currentHeading).Copy

            Set Target = newWordDoc.Content
            Target.Collapse Direction:=wdCollapseEnd
            Target.Paste
        Else
            MsgBox "Could not find '" & ExpectedHeading & "'"
        End If

        counter = counter + 1
    Loop

    wordApp.Quit

    If currentHeading <= headings.Count Then
        MsgBox "Done"
    End If
End Sub

My problem is now that it closes everything automaticly. But I would like to keep everything open and save it later, can somebody help me with that? Also its only loading the data out of that specific file I defined, is there a possibility, to load the documents of a folder?

Answer 2

Try:

Sub Demo()
'Note: A reference to the Word library must be set, via Tools|References
Const StrDocNm As String = "file:///J:\Test.docx"
If Dir(StrDocNm) = "" Then Exit Sub
Dim WkSht As Worksheet, LRow As Long, r As Long
Dim wdApp As New Word.Application, wdRng As Word.Range
Dim wdDocTgt As Word.Document, wdDocSrc As Word.Document
Set WkSht = ThisWorkbook.Sheets("Sheet1")
LRow = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
Set wdDocSrc = wdApp.Documents.Open(Filename:=StrDocNm, ReadOnly:=False, AddToRecentfiles:=False)
Set wdDocTgt = wdApp.Documents.Add
With wdDocSrc
    'process the source document
    With .Range
      For r = 1 To LRow
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = WkSht.Range("A" & r).Text
          .Style = wdStyleHeading1
          .Replacement.Text = ""
          .Format = True
          .Forward = True
          .Wrap = wdFindContinue
          .Execute
        End With
        If Find.Found = True Then
          Set wdRng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
          wdDocTgt.Range.Characters.Last.FormattedText = wdRng.FormattedText
        End If
      Next
    End With
    .Close SaveChanges:=False
End With
wdApp.Visible = True
Set wdRng = Nothing: Set wdDocSrc = Nothing: Set wdDocTgt = Nothing: Set wdApp = Nothing
End Sub