Sub Splitter()
'------------------------------------------------------------------------------------------------------------------
' splitter Macro
' Macro created by Doug Robbins to save each letter created by a mailmerge as a separate file.
' 20140102 Aangepast door OctaFish om documenten los op te slaan m.b.v. de naam in de 1e alinea.
' 20141210 Macro gebruikt nu een functie om op te slaan in een aparte map op de desktop van de user.
'------------------------------------------------------------------------------------------------------------------
Dim Letters As Integer, Counter As Integer
Dim DocName As String, sRange As String, Pad As String
Dim aRange As Range
DocName = "Brief "
Pad = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Test"
If CreateFolder(Pad) = False Then
MsgBox "Het pad kon niet worden aangemaakt; check de gegevens."
Exit Sub
End If
If Not Right(Pad, 1) = Application.PathSeparator Then Pad = Pad & Application.PathSeparator
Letters = ActiveDocument.Sections.Count
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
ActiveDocument.Sections.First.Range.Cut
Documents.Add
Selection.Paste
'-----------------------------------------------------------------------------
'Naam samenstellen uit 1e alinea van tekst
'-----------------------------------------------------------------------------
Set aRange = ActiveDocument.Paragraphs(1).Range
DocName = aRange.text
If Right(DocName, 1) = Chr(13) Or Right(DocName, 1) = Chr(10) Then
DocName = Left(DocName, Len(DocName) - 1)
End If
'-----------------------------------------------------------------------------
ActiveDocument.Sections(2).PageSetup.SectionStart = wdSectionContinuous
ActiveDocument.SaveAs FileName:=Pad & DocName & ".docx", FileFormat:=wdFormatDocument, _
Password:="", AddToRecentFiles:=True, WritePassword:="", EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
ActiveWindow.Close
Counter = Counter + 1
Wend
End Sub
