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