Sub Splitter()
'------------------------------------------------------------------------------------------------------------------
' splitter Macro
' Macro created by Doug Robbins to save each letter created by a mailmerge as a separate file.
' Adapted by OctaFish to extend Filename with 1st paragraph
'------------------------------------------------------------------------------------------------------------------
Dim Letters As Integer, Counter As Integer
Dim DocName As String, sRange As String
Dim Pad As String, sNullen As String
Dim aRange As Range
Dim aDoc As Document, aDocNew As Document
DocName = "Recept "
Pad = "H:\Temp\Word\"
Set aDoc = ActiveDocument
Letters = aDoc.Sections.Count
For Counter = 1 To Len(Letters)
sNullen = sNullen & "0"
Next Counter
sNullen = sNullen & "0"
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
'-----------------------------------------------------------------------------
'Naam samenstellen op basis van nummering
'-----------------------------------------------------------------------------
DocName = Right(sNullen & LTrim$(Str$(Counter)), Len(Letters) + 1) & "_"
'-----------------------------------------------------------------------------
aDoc.Sections.First.Range.Cut
Set aDocNew = Documents.Add
Selection.Paste
'-----------------------------------------------------------------------------
'Naam samenstellen uit 1e alinea van tekst
'-----------------------------------------------------------------------------
With aDocNew
Set aRange = .Paragraphs(1).Range
DocName = DocName & aRange.Text
If Right(DocName, 1) = Chr(13) Or Right(DocName, 1) = Chr(10) Then
DocName = Left(DocName, Len(DocName) - 1)
End If
'-----------------------------------------------------------------------------
.Sections(2).PageSetup.SectionStart = wdSectionContinuous
.SaveAs _
FileName:=Pad & DocName & ".doc", _
FileFormat:=wdFormatDocument, _
AddToRecentFiles:=False
End With
ActiveWindow.Close
Counter = Counter + 1
Wend
End Sub