Sub Segmenter()
Application.ScreenUpdating = False
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
  Set Rng = .Range(0, 0): j = 1000
  For i = 1 To -Int(-.ComputeStatistics(wdStatisticWords) / j)
    If .Range(Rng.Start, .Range.End).ComputeStatistics(wdStatisticWords) < j Then Exit For
    With Rng
      .MoveEnd wdWord, j
      .End = .Paragraphs.Last.Range.End
      If .End = DocSrc.Range.End Then Exit For
      .InsertAfter vbCr
      .Collapse wdCollapseEnd
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub