Необходимо зациклить код, чтобы извлечь текст из документа и вставить его в другой документ

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