Sub SaveExtractToDocument()
'Graham Mayor - https://www.gmayor.com - Last updated - 02 May 2021
Dim oDoc As Document, oNewDoc As Document
Dim oRng As Range, oNewRng As Range
Dim strPath As String
Dim FSO As Object

    If Documents.Count = 0 Then
        MsgBox "No document open", vbCritical
        GoTo lbl_Exit
    End If

    If Len(Selection) = 1 Then
        MsgBox "Nothing selected", vbCritical
        GoTo lbl_Exit
    End If

    Set oDoc = ActiveDocument
    strPath = Environ("USERPROFILE") & "\Desktop\Extract.docx"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(strPath) Then
        Set oNewDoc = Documents.Open(strPath)
    Else
        Set oNewDoc = Documents.Add
        oNewDoc.SaveAs2 strPath
    End If
    oDoc.Activate
    Set oRng = Selection.Range
    oRng.Copy
    Set oNewRng = oNewDoc.Range
    oNewRng.Collapse 0
    oNewRng.Paste
    oNewRng.InsertParagraphAfter
    'oNewDoc.Save 'Optional
lbl_Exit:
    Set oDoc = Nothing
    Set oNewDoc = Nothing
    Set oRng = Nothing
    Set oNewRng = Nothing
    Set FSO = Nothing
    Exit Sub
End Sub