Question

我有一个包含多个主题行的文档-我认为有人将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

Answer 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

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

1 个答案: