Option Explicit

Sub CopyHighlightsSelectedToOtherDoc()
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range, orng As Range
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Const strDoc As String = "C:\Users\apple\Desktop\container.docx"    'folder must exist
    Set ThisDoc = ActiveDocument
    Set r = Selection.Range
    Set orng = Selection.Range
    If Len(r) > 0 Then
        If fso.FileExists(strDoc) Then
            Set ThatDoc = Documents.Open(strDoc)
        Else
            On Error GoTo err_Handler
            Set ThatDoc = Documents.Add
            ThatDoc.SaveAs2 strDoc
        End If
        With r.Find
            .Highlight = True
            Do While .Execute(Forward:=True) = True And r.InRange(orng)
                ThatDoc.Range.InsertAfter r.Text & vbCrLf
                r.Collapse 0
            Loop
        End With
        ThatDoc.Save
    Else
        MsgBox "Nothing selected"
    End If
lbl_Exit:
    Set r = Nothing
    Set orng = Nothing
    Exit Sub
err_Handler:
    ThatDoc.Close 0
    MsgBox "Target document not available"
    Err.Clear
    GoTo lbl_Exit
End Sub