Sub BreakOnPage()
Dim i As Long, docNum As Long, re As Object, mt, fn As String
Set re = CreateObject("vbscript.regexp")
re.ignorecase = True
re.Global = True
re.Pattern = "[0-9A-ZА-ЯЁ]+"

Selection.HomeKey wdStory
' Used to set criteria for moving through the document by page.
Application.Browser.Target = wdBrowsePage
ChangeFileOpenDirectory "C:\temp"

For i = 1 To ActiveDocument.BuiltInDocumentProperties("Number of Pages")
  
  'Select and copy the text to the clipboard
  ActiveDocument.Bookmarks("\page").Range.Copy
  
  ' Open new document to paste the content of the clipboard into.
  Documents.Add
  Selection.Paste
  ' Removes the break that is copied at the end of the page, if any.
  Selection.TypeBackspace
  
  Set mt = re.Execute(ActiveDocument.Range.Text)
  Select Case mt.Count
  Case Is > 1:  fn = mt(0) & "_" & mt(1)  'есть 2 слова
  Case 1:       fn = mt(0)                'есть только 1 слово
  Case Else                               'нет слов, используем номер
    docNum = docNum + 1
    fn = Format$(docNum, "000")
  End Select
  ActiveDocument.SaveAs FileName:=fn & ".doc"
  ActiveDocument.Close
  
  ' Move the selection to the next page in the document
  Application.Browser.Next
Next i
ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub