Sub Split_()
Selection.EndKey Unit:=wdStory
Letters = Selection.Information(wdActiveEndSectionNumber)
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
    Application.ScreenUpdating = False
    With Selection
        .HomeKey Unit:=wdStory
        .EndKey Unit:=wdLine, Extend:=wdExtend
        .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    End With
    sName = Selection
    DocName = "C:Documents" & sName & ".docx"
    ActiveDocument.Sections.First.Range.Cut
    Documents.Add
    'Selection.Paste
    'With Selection
    '    .Paste
    '    .HomeKey Unit:=wdStory
    '   .MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
    '   .Delete
    'End With
   ActiveDocument.SaveAs2 FileName:=DocName, _
    FileFormat:=wdFormatXMLDocument, _
   CompatibilityMode:=14
   ActiveWindow.Close
    Counter = Counter + 1
    Application.ScreenUpdating = True
Wend
End Sub