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

问题描述

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

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.

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

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.

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

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.

推荐答案

我明白了.以下内容并不是很完美，因为它使用了我总是会尽量避免使用的选择，但这是我知道实现这一目标的唯一方法.

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.

免责声明1:这是在Word VBA中制作的，因此您需要稍作修改，例如设置对Word的引用，使用wrdApp = New Word.Application对象并将doc和newdoc显式声明为Word.Document

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.

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

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. ;-)

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

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...

是的，粘贴再次起作用. :-)

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

如果您需要在第1列的某个表中搜索功能"，并在第2列中添加描述，并且需要在新文档中使用该描述，请尝试以下操作:

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

稍作修改，因此您可以粘贴而不会覆盖newdoc中的现有内容:除了使用newdoc.Range.Paste之外，还可以使用以下方法:

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

这篇关于将VBA与Powerpoint结合使用以在Word Doc中搜索标题并将文本复制到另一个Word文档中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！