Sub SaveSelectedTextToNewDocument()
    If Selection.Words.Count > 0 Then
    'Copy the selected text
    Selection.Copy            

    'Open a new document and paste the copied text into it
    Dim objNewDoc As Document
    Set objNewDoc = Documents.Add
    Selection.Paste

    'Get the first 10 characters as the filename of the new document and save them
    Dim objFileName As Range
    Set objFileName = objNewDoc.Range(Start:=0, End:=10)
    objNewDoc.SaveAs FileName:="C:\Users\Test\Desktop\" & objFileName & ".docx"
    Else

    End If
End Sub