将VBA与Powerpoint一起使用可在Word Doc中搜索标题并将文本复制到另一个Word文档中

Question

我正在使用Powerpoint幻灯片，其中列出了一些文本。 我必须在包含大量标题和文本的Word文档中搜索这些文本。 找到标题文本后，我需要复制标题下的文本并粘贴到新文档中。

基本上，VBA编码必须在Powerpoint VBA中完成，在后台有两个文档用于搜索文本并将其粘贴到另一个文档中。

我打开了doc一词。 但是，我一直无法搜索其中的文本并选择要复制到另一个文档的文本。 请帮助我。

Answer 1

我懂了。 以下内容并不是很完美，因为它使用了我总是试图避免的选择，但这是我知道实现这一目标的唯一方法。

免责声明1：这是在Word VBA中完成的，因此您需要进行一些wrdApp = New Word.Application ，例如设置对Word的引用，使用wrdApp = New Word.Application对象并将doc和newdoc明确声明为Word.Document 。

免责声明2：由于您搜索的是文本而不是相应的标题，因此请注意，这将找到该文本的首次出现，因此最好不要在几章中使用相同的文本。 ;-)

免责声明3：我无法粘贴了！ :-(我的剪贴板已设置好，可以粘贴到其他地方，但是我不能粘贴到这里。代码会先进行编辑，希望在一分钟后...

编辑：是的，再次粘贴工作。 :-)

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

编辑：如果您需要在第1列的某个表中搜索“功能”，并在第2列进行描述，并且需要在新文档中使用该描述，请尝试以下操作：

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

编辑：稍加调整，因此您可以粘贴而不覆盖newdoc中的现有内容：代替newdoc.Range.Paste只需使用以下内容即可：

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