Split word document by some count of pages

[mykolaq]

Hello! I need to split word document and each new document must consist of, for example, ten pages.
I know ho to select this count of pages, but i dont understand what to do after. This code below select ten pages, i understand how to save it, but how to create loop.

Sub Макрос1()'
' Макрос1 Макрос
'
'
Dim rgePages As Range


Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=1


Set rgePages = Selection.Range


Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=10


rgePages.End = Selection.Bookmarks("\Page").Range.End


rgePages.Select


End Sub

[gmaxey]

Something like this:


Option Explicit
Sub CreateSubFiles()
SplitFileIntoPageBundles 10, True
lbl_Exit:
Exit Sub
End Sub

Sub SplitFileIntoPageBundles(lngBundleSize As Long, _
Optional bSaveBundles As Boolean = False)
Dim bNotEndOfDoc As Boolean
Dim oDoc As Document, oDocBundle As Document
Dim lngLastPage As Long
Dim strStartBM As String
Dim strEndBM As String
Dim lngPageCurrent As Integer
Dim oRngContent As Range
Dim lngFileIndex As Long

'Initialize variables
lngBundleSize = 3
bNotEndOfDoc = True
lngLastPage = Range.Information(wdActiveEndPageNumber)
strStartBM = "Page_1"
Set oDoc = ActiveDocument
lngPageCurrent = 1
lngFileIndex = 1

'Anchor the first bundle start range.
oDoc.Range(0, 0).Select
oDoc.Bookmarks.Add strStartBM, Selection.Range

While lngPageCurrent <= lngLastPage And bNotEndOfDoc = True
'Select bundle text. Full bundled size or rest of text.
If lngBundleSize + lngPageCurrent <= lngLastPage Then
Selection.GoTo wdGoToPage, wdGoToNext, lngBundleSize + lngPageCurrent
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Else
Selection.EndKey Unit:=wdStory
bNotEndOfDoc = False
End If
'Anchor the bundle end range.
lngPageCurrent = Selection.Information(wdActiveEndPageNumber)
If bNotEndOfDoc Then
strEndBM = "Page_" & Selection.Information(wdActiveEndPageNumber)
Else
strEndBM = "End_of_Doc"
End If
oDoc.Bookmarks.Add strEndBM, Selection.Range
Set oRngContent = oDoc.Bookmarks(strStartBM).Range
oRngContent.End = Bookmarks(strEndBM).Range.End + 1
Set oDocBundle = Documents.Add
With oDocBundle
.Activate
.Range.FormattedText = oRngContent.FormattedText
.Range.Paragraphs.Last.Range.Delete
If .Bookmarks.Exists(strStartBM) Then .Bookmarks(strStartBM).Delete
.Bookmarks(strEndBM).Delete
If bSaveBundles Then
.SaveAs2 fcnFilename(oDoc.FullName, " Bundle " & lngFileIndex)
lngFileIndex = lngFileIndex + 1
.Close
End If
End With
With oDoc
.Activate
.Bookmarks(strEndBM).Range.Select
.Bookmarks(strStartBM).Delete
.Bookmarks(strEndBM).Delete
End With
Selection.MoveRight Unit:=wdCharacter, Count:=1
If lngPageCurrent < lngLastPage Then
strStartBM = "Page_" & Selection.Information(wdActiveEndPageNumber)
oDoc.Bookmarks.Add strStartBM, Selection.Range
lngPageCurrent = Selection.Information(wdActiveEndPageNumber)
Else
bNotEndOfDoc = False
End If
Wend
lbl_Exit:
Exit Sub
End Sub
Function fcnFilename(strFilePath, strSuffix) As String
Dim oFSO As Object
Dim strName As String
Set oFSO = CreateObject("scripting.filesystemobject")
With oFSO
fcnFilename = .BuildPath(.GetParentFolderName(strFilePath), .GetBaseName(strFilePath)) _
& strSuffix & "." & .GetExtensionName(strFilePath)
End With
Set oFSO = Nothing
lbl_Exit:
Exit Function
End Function

[mykolaq]

Greg, big thank for script, but i have an error. lngLastPage = Range.Information(wdActiveEndPageNumber) - compile error, variable not defined. Strange, cause it's defined

[gmaxey]

mykolag,

Try rearranging like this:

Set oDoc = ActiveDocument
lngLastPage = oDoc.Range.Information(wdActiveEndPageNumber)
strStartBM = "Page_1"
lngPageCurrent = 1
lngFileIndex = 1