Mailings met meerdere pagina's splitten

Sub SplitMailings()
'
' SplitMailingsMacro
'
Dim rng As Range
Dim i As Long
Dim intPages As Integer
Dim lngStart As Long
Dim lngEnd As Long
Dim strID As String
Dim wd As Document

Set rng = ActiveDocument.Content
lngStart = 1
intPages = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
For i = 1 To ActiveDocument.Sections.Count 'intPages 'is de pagina waarop wordt begonnen of gebruik
Set rng = rng.GoTo(wdGoToSection, , i) 'of gebruik wdGoToSectionBreakNexPage of wdGoToPage
lngEnd = rng.Start - 1
If lngEnd > lngStart Then 'de eerste keer niet
ActiveDocument.Range(lngStart, lngEnd).Copy
Set wd = Documents.Add
With ActiveDocument.PageSetup
 .LeftMargin = InchesToPoints(1.58) 'is 4cm
 .RightMargin = InchesToPoints(1.58)
 .TopMargin = InchesToPoints(1.97) 'is 5cm
 .BottomMargin = InchesToPoints(1.37) 'is 3,5cm, 3cm is 1.17
End With
wd.Content.Paste
wd.SaveAs "H:\FF\" & strID & " Eropuit.docx" 'wijzig pad en bestandsnaam
wd.Close
End If
lngStart = lngEnd + 1
With rng.Find
.Text = "kenmerk^t:" 'kenmerk is KLTNR
 
If .Execute = True Then
rng.Collapse wdCollapseEnd
rng.Move wdCharacter, 1
rng.Expand wdWord
strID = Trim(rng)
End If
End With
Next
ActiveDocument.Range(lngStart, ActiveDocument.Content.End).Copy
Set wd = Documents.Add
wd.Content.Paste
wd.SaveAs "H:\FF\" & strID & " Eropuit.docx" 'wijzig pad en bestandsnaam
wd.Close
Set wd = Nothing
End Sub

Sub SplitIntoPages()
'

Dim docMultiple As Document
Dim docSingle As Document
Dim rngPage As Range
Dim iCurrentPage As Integer
Dim iPageCount As Integer
Dim strNewFileName As String

Application.ScreenUpdating = False 'Makes the code run faster and reduces screen flicker a bit.
Set docMultiple = ActiveDocument 'Work on the active document (the one currently containing the Selection)
Set rngPage = docMultiple.Range 'instantiate the range object
iCurrentPage = 1 'get the document's page count
iPageCount = docMultiple.Content.ComputeStatistics(wdStatisticPages) 

Do Until iCurrentPage > iPageCount

If iCurrentPage = iPageCount Then
	rngPage.End = ActiveDocument.Range.End 'last page (there won't be a next page)

Else
	'Find the beginning of the next page
	'Must use the Selection object. The Range.Goto method will not work on a page
  Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 1
	'Set the end of the range to the point between the pages
  rngPage.End = Selection.Start

End If
  rngPage.Copy 'copy the page into the Windows clipboard
  Set docSingle = Documents.Add 'create a new document
  docSingle.Range.Paste 'paste the clipboard contents to the new document
	'remove any manual page break to prevent a second blank
  docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
	'build a new sequentially-numbered file name based on the original multi-paged file name and path
  strNewFileName = Replace(docMultiple.FullName, ".doc", "_" & Right$("000" & iCurrentPage, 4) & ".doc")
  docSingle.SaveAs strNewFileName 'save the new single-paged document
  iCurrentPage = iCurrentPage + 1 'move to the next page
  docSingle.Close 'close the new document
  rngPage.Collapse wdCollapseEnd 'go to the next page

Loop 'go to the top of the do loop
Application.ScreenUpdating = True 'restore the screen updating
	'Destroy the objects.

Set docMultiple = Nothing
Set docSingle = Nothing
Set rngPage = Nothing

End Sub