

December 5, 2016

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
1 Guest(s)
