Sub doc_splitter()
' Copyright by Zeeshan Shabbir Qureshi
' Use at your own risk

origdoc = ActiveDocument.Name

Dim Mldg, Titel, Voreinstellung, Batches
Mldg = "Number of batches?"
Titel = "Freeware by www.ecm-e.de, W. Polmann."
Voreinstellung = "1" ' Voreinstellung festlegen.
' Meldung, Titel und Standardwert anzeigen.
Batches = InputBox(Mldg, Titel, Voreinstellung)

Prozentsprung = 100 / Batches

For x = 1 To Batches


ActiveDocument.SaveAs FileName:="Teil_" & x & "_" & origdoc & ".doc", _
FileFormat:=wdFormatDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False


EndeProzentsprung = Prozentsprung * x
AnfangProzentsprung = EndeProzentsprung - Prozentsprung


Selection.GoTo What:=wdGoToPercent, Which:=wdGoToNext, Count:=AnfangProzentsprung, Name:=""
Anfang = Selection.Start

Selection.GoTo What:=wdGoToPercent, Which:=wdGoToNext, Count:=EndeProzentsprung, Name:=""
' Bis zur nächsten Absatzmarke hoch


Selection.Find.ClearFormatting
With Selection.Find
.text = "^p"
.Replacement.text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.MoveRight Unit:=wdCharacter, Count:=1
Ende = Selection.End


Set Range = ActiveDocument.Range(Anfang, Ende)


Range.Select
Selection.Copy


Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Paste
ActiveDocument.Save
ActiveDocument.Close

Documents.Open FileName:=origdoc, _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto

Next x

ActiveDocument.Close

End Sub
'---------End---------------