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

Question

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

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

我打开了word doc。但是搜索其中的文本并选择它以复制到另一个文档是我无法做到的。请帮助我。

Answer 1

我明白了。以下内容并不十分优雅，因为它使用了我一直试图避免的选择，但这是我所知道的实现这种事情的唯一方法。

免责声明 1：这是用 Word VBA 制作的，因此您需要稍作调整，例如设置对 Word 的引用，使用 wrdApp = New Word.Application object并将 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 列中某些 table 中的 "feature" 以及第 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

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

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

powerpoint

vba

ms-word