Use VBA with Powerpoint to Search titles in a Word Doc and Copy Text into another Word Document

Question

I'm working on a Powerpoint slide, where I few texts are listed. I have to search for these texts in a Word Document which has a lot of Headings and Texts. After I find the title text, I need to copy the text under the Heading and paste in a new document.

Basically, the VBA coding has to be done in the Powerpoint VBA, with two documents in the background for searching text and pasting it in another.

I've opened the word doc. But searching the text in it and selecting it for copying to another document is what I've not been able to do. Kindly help me.

Answer 1

I see. The following is not exactly elegant since it uses Selection which I always try to avoid but it is the only way I know to achieve such a thing.

Disclaimer 1: this is made in Word VBA, so you will need a slight adaption, like set a reference to Word, use a wrdApp = New Word.Application object and declare doc and newdoc explicitely as Word.Document.

Disclaimer 2: Since you search for text instead of the respective heading, beware that this will find the first occurence of that text so you better not have the same text in several chapters. ;-)

Disclaimer 3: I cannot paste anymore! :-( My clipboard is set, it pastes elsewhere but I just cannot paste in here. Code follows with first edit, hopefully in a minute...

Edit: yepp, pasting works again. :-)

Sub FindChapter()

Dim doc As Document, newdoc As Document
Dim startrange As Long, endrange As Long
Dim HeadingToFind As String, ChapterToFind As String

ChapterToFind = "zgasfdiukzfdggsdaf" 'just for testing

Set doc = ActiveDocument
Set newdoc = Documents.Add
doc.Activate
Selection.HomeKey unit:=wdStory

With Selection
    With .Find
        .ClearFormatting
        .Text = ChapterToFind
        .MatchWildcards = False
        .MatchCase = True
        .Execute
    End With

    If .Find.Found Then
    '**********
    'Find preceding heading to know where chapter starts
    '**********
        .Collapse wdCollapseStart
        With .Find
            .Text = ""
            .Style = "Heading 1"
            .Forward = False
            .Execute
            If Not .Found Then
                MsgBox "Could not find chapter heading"
                Exit Sub
            End If
        End With

        .MoveDown Count:=1
        .HomeKey unit:=wdLine
        startrange = .Start

        '*********
        'Find next heading to know where chapter ends
        '*********
        .Find.Forward = True
        .Find.Execute
        .Collapse wdCollapseStart
        .MoveUp Count:=1
        .EndKey unit:=wdLine
        endrange = .End

        doc.Range(startrange, endrange).Copy
        newdoc.Content.Paste
        newdoc.SaveAs2 doc.Path & "\" & HeadingToFind & ".docx", wdFormatFlatXML
    Else
        MsgBox "Chapter not found"
    End If

End With


End Sub

Edit: If you need to search for a "feature" that will be in some table in column 1 with the description in column 2 and you need that description in a new doc, try this:

Sub FindFeature()

Dim doc As Document, newdoc As Document
Dim FeatureToFind As String
Dim ro As Long, tbl As Table

FeatureToFind = "zgasfdiukzfdggsdaf"   'just for testing

Set doc = ActiveDocument
Set newdoc = Documents.Add
doc.Activate
Selection.HomeKey unit:=wdStory

With Selection
    With .Find
        .ClearFormatting
        .Text = FeatureToFind
        .MatchWildcards = False
        .MatchCase = True
        .Execute
    End With

    If .Find.Found Then
        Set tbl = Selection.Tables(1)
        ro = Selection.Cells(1).RowIndex
        tbl.Cell(ro, 2).Range.Copy
        newdoc.Range.Paste
    End If
End With


End Sub

Edit: Slight adaptation so you can paste without overwriting existing content in newdoc: Instead of newdoc.Range.Paste just use something along the line of this:

 Dim ran As Range
 Set ran = newdoc.Range
 ran.Start = ran.End
 ran.Paste