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 = '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 + '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 multipaged 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 + '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 loop Application.ScreenUpdating = True 'restore the screen updating 'Destroy the objects Set docMultiple = Nothing Set docSingle = Nothing Set rngPage = Nothing End Sub