Option Explicit

Sub CopyEachPageToNewDocument()
  Dim objDocSrc   As Document
  Dim objDocDest  As Document
  Dim rngPage     As Range

  Dim strFileName As String

  Dim nPagesCnt   As Integer
  Dim nPage       As Integer
  Dim nDocNum     As Integer

  Set objDocSrc = ActiveDocument

  strFileName = objDocSrc.Path & "\" & "Test_"

  Application.ScreenUpdating = False

  objDocSrc.Windows(1).View.Type = wdPageView
  objDocSrc.Range(0, 0).Select

  Application.Browser.Target = wdBrowsePage

  nDocNum = 0

  nPagesCnt = objDocSrc.ComputeStatistics(wdStatisticPages)
  For nPage = 1 To nPagesCnt
    Set rngPage = objDocSrc.Bookmarks("\Page").Range
    If Right$(rngPage.Text, 1) = Chr(12) Then
      rngPage.SetRange _
            Start:=rngPage.Start, End:=rngPage.End - 1
    End If

    Set objDocDest = Documents.Add _
            (Template:=objDocSrc.AttachedTemplate.FullName)

    objDocDest.Content.FormattedText = rngPage.FormattedText

    nDocNum = nDocNum + 1
    objDocDest.SaveAs strFileName & Format$(nDocNum, "0000")
    objDocDest.Close

    objDocSrc.Activate
    Application.Browser.Next
  Next nPage

  objDocSrc.Range(0, 0).Select

  Application.ScreenUpdating = True

  Set rngPage = Nothing
  Set objDocDest = Nothing
  Set objDocSrc = Nothing
End Sub