需要循环代码以从文档中获取文本并将其粘贴到另一个文档中答案

【问题标题】：Need to loop a code to grab text from a document and paste it into another document需要循环代码以从文档中获取文本并将其粘贴到另一个文档中
【发布时间】：2019-09-08 02:16:21
【问题描述】：

我有一个包含多个主题行的文档 - 我认为有人将 100 封电子邮件复制并粘贴到一个 Word 文档中。我想抓取所有主题行并将它们粘贴到新文档中以进行进一步修改。

我使用了在这里找到的各种代码来接近。到目前为止，我能够获取主题的第一次迭代并将其粘贴到新文档中，但我无法弄清楚如何循环它，以便它继续运行在文档中，即捕获另一个“99”主题的实例。这就是我正在尝试的

Sub SubjectFind()

Application.ScreenUpdating = False

Application.Browser.Target = wdBrowseSeciton

    For I = 1 To ActiveDocument.Sections.Count
    Dim rng1 As Range
    Dim rng2 As Range
    Dim strTheText As String
    Dim DestFileNum As Long
    Dim sDestFile As String

    sDestFile = “C:\Users\pascualt\Documents\Doc1.txt” ‘Location of External File
    DestFileNum = FreeFile()

    Open sDestFile For Output As DestFileNum ‘This opens new file with name DestFileNum
    Set rng1 = ActiveDocument.Range
    If rng1.Fine.Execute(Findtext:=”Subject:”) Then
        Set rng2 = ActiveDocument.Range(rng1.End, ActiveDocument.Range.End)
        If rng2.Fine.Execute(Findtext:=”Ref:”) Then
            strTheText = ActiveDocument.Range (rng1.End, rng2.Start).Text
            Print #DestFileNum, strTheText ‘Print # will write to external file
        End If
    End If
    Application.Browser.Next
        Next I
    Close #DestFileNum
End Sub

【问题讨论】：

标签： vba ms-word

【解决方案1】：

试一试，例如：

Sub Demo()
Application.ScreenUpdating = False
Dim StrOut As String, wdDoc As Document
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "Subject:*^13"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    StrOut = StrOut & .Text
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Set wdDoc = Documents.Add
wdDoc.Range.Text = StrOut
Application.ScreenUpdating = True
End Sub

【讨论】：