http://q.hatena.ne.jp/1379290598 の続きだとして､ｼｰﾄの変更ｲﾍﾞﾝﾄの処理の最後の方に､以下のようなｺｰﾄﾞを追加します｡
ﾃﾞｰﾀを自動で追加している行の位置が､前回と同じで target_row という変数に入っていることを前提としています｡

Private Sub Worksheet_Change(ByVal Target As Range)

 ...

 Application.EnableEvents = False

 ...

  ' ここから､今回追加するｺｰﾄﾞ

  ' 書き込み先が 10000 以上になったら
 If target_row >= 10000 Then

 Const save_dir = "d:\"  ' 保存先のﾃﾞｨﾚｸﾄﾘ(￥で終わるように)
 Const save_range = "A5:E65000"  ' 保存対象の範囲
 
  ' 保存対象を切り取る
 Range(save_range).Select
 Selection.Cut
 
 ’新しいﾌﾞｯｸを作成して､ｼｰﾄに切り取ったﾃﾞｰﾀを貼りつける
 Set newBook = Workbooks.Add
 newBook.ActiveSheet.Paste
 
  ' 日付+時刻のﾌｧｲﾙ名で保存
 filename = save_dir & Format(now, "yyyymmdd-HHMM") & ".xlsx"
 newBook.SaveAs Filename:=filename, FileFormat:=xlOpenXMLWorkbook
 newBook.Close
 
 End If

  ' ここまで

 Application.EnableEvents = True

End Sub

ﾏｸﾛ入りで保存する場合

Private Sub Worksheet_Change(ByVal Target As Range)
 Const 列 = "E"
 Const 消去件数 = 10000
 Const 消去範囲 = "A5:E65000"
 
 Dim c As Long
 
 If Cells(1, 列).Address <> Target.Address Then Exit Sub
 c = 5
 Application.EnableEvents = False
 If Cells(5, 列).Value = "" Then
 c = 5
 Else
 If Cells(6, 列).Value = "" Then
 c = 6
 Else
 c = Cells(5, 列).End(xlDown).Row + 1
 End If
 End If
 Cells(c, 列) = Cells(1, 列)
 
 If c - 4 >= 消去件数 Then
 d = Format(Now, "yyyymmddhhmmss") & ".xls"
 ActiveSheet.Select
 ActiveSheet.Copy
 ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & d
 ActiveWorkbook.Close
 Range(消去範囲).Clear
 End If
 
 Application.EnableEvents = True


End Sub

a-kuma3 様

お世話になります｡
昨晩､10000行で保存･ﾃﾞｰﾀｰ消去を試して見ました｡
結果は保存ﾌｧｲﾙのｴﾗｰがでて､保存できずにｽｸﾘﾌﾟﾄは停止していました｡

ｴﾗｰ画像を取得しているのですが､掲載方法が分かりませんので文章で説明させて頂きます｡
------------------------------------------------------
Microsoft Visual Basic
実行時ｴﾗｰ '1004'
WorkbookｸﾗｽのSabeAsﾒｿｯﾄﾞが失敗しました｡

終了 ﾃﾞﾊﾞｯｸﾞ ﾍﾙﾌﾟ
--------------------------------------------------------

使用中ｽｸﾘﾌﾟﾄは次の通りです｡

Private Sub Worksheet_Change(ByVal Target As Range)

Const Target_Column = 5 ' E列
Const Start_Row = 5 ' E5 を開始
Const Input_Row = 1 ' E1 を入力

' E1 かどうか確認
If Target.Row <> Input_Row Or Target.Column <> Target_Column Then Exit Sub


Application.EnableEvents = False


If IsEmpty(Cells(Start_Row, Target_Column)) Then
target_row = Start_Row
ElseIf IsEmpty(Cells(Start_Row + 1, Target_Column)) Then
target_row = Start_Row + 1
Else
target_row = ActiveSheet.Cells(5, Target_Column).End(xlDown).Row + 1
End If

Cells(target_row, Target_Column).Value = Cells(1, Target_Column).Value
Cells(target_row, 2).Value = Cells(1, 2).Value
Cells(target_row, 3).Value = Cells(1, 3).Value
Cells(target_row, 4).Value = Cells(1, 4).Value

If Cells(target_row, Target_Column).Value <> "" Then
Target.Offset(target_row - 1, -4).Value = Date + Time
' Target.Offset(Target_Row - 1, -3).Value = Time
End If

'----------------- 書き込み先が 10000 以上になったら --------------------------
If target_row >= 10000 Then

Const save_dir = "c:\" ' 保存先のﾃﾞｨﾚｸﾄﾘ(￥で終わるように)
Const save_range = "A5:E10000" ' 保存対象の範囲

' 保存対象を切り取る
Range(save_range).Select
Selection.Cut

'新しいﾌﾞｯｸを作成して､ｼｰﾄに切り取ったﾃﾞｰﾀを貼りつける
Set newBook = Workbooks.Add
newBook.ActiveSheet.Paste

' 日付+時刻のﾌｧｲﾙ名で保存
Filename = save_dir & Format(Now, "yyyymmdd-HHMM") & ".xlsx"
newBook.SaveAs Filename:=Filename, FileFormat:=xlOpenXMLWorkbook
newBook.Close
End If

Application.EnableEvents = True

End Sub


保存しようとしたｴｸｾﾙﾌｧｲﾙは選択ｾﾙが青くなっていてﾃﾞｰﾀｰが消去されていました｡
また､保存先ﾌｧｲﾙは名前がbook1.xlsとなって､画面上に開いたままになっていました｡


以上ですが､対処の方法をご教示頂けますと助かります｡