Sub TextSplitter()
Dim Rng As Range
Application.ScreenUpdating = False
With ActiveDocument
  Set Rng = .Range(0, 0)
  Do
    With Rng
      On Error GoTo ErrExit
      .MoveEndUntil cset:=vbCr, Count:=wdForward
      If Len(.Text) > 500 Then
        .End = .Start + 500
        .End = .Start + InStrRev(Rng.Text, ".") + 1
        If .Characters.Last.Text <> vbCr Then
          .Characters.Last.Delete
          .InsertAfter vbCr & "*** " & vbCr
        End If
      End If
      DoEvents
      .Start = .Paragraphs.Last.Next.Range.Start
    End With
  Loop Until Rng Is Nothing
ErrExit:
  With .Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "*** " & vbCr
    .Replacement.Text = "*** "
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
  End With
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub