エクセル2010です。
Sheets("DATA")にある822件のデータを、D列のデータ（担当者名）をキーにフィルター抽出し、雛形のシートにコピーして、そのシートを別ファイルとして名前をつけて、指定したフォルダーのサブフォルダに保存するマクロです。（サブフォルダ名はデータのG列にある文字列です。）
キーとなる担当の数は223です。
以下のコードで一応作動するのですが、同じデータを使っても2回に一回くらいの割合で保存ができず、
wb(1).SaveAs Filename:=SaveDir & "\" & bcde & "_" & Trim(myC.Value) & ".xlsx"
のところで止まってしまいます。
エラーは
「実行時エラー1004 SaveAsメソッドは失敗しました。Workbookオブジェクト」
というものです。このとき、画面上ではあたらしいファイルが出来あがっております。しかしその出来てるファイルを手動で保存しようと思っても、
「○○○（ファイル名）は保存中にエラーが検出されました。いくつかの機能を削除または修復することによりファイルを保存できる場合があります」
とでてしまいます。
まだテスト段階で、同一のデータでテストしているのですが、止まるデータは30件目であったり、140件目であったり、まちまちです。2回に1回くらいは最後まで動き、すべて正しく作成され保存できているので、データの問題ではないと思います。
ほかにどんな問題が考えられるのでしょうか？とても困っています。
Sub TEST20151114()
Dim SaveDir As String, bcde As String, sbfdr As String
Dim wb(1) As Workbook
Dim i As Long, x As Long
Dim myRng As Range, myC As Range
Dim t
t = Time
Set wb(0) = ThisWorkbook
Set myRng = wb(0).Sheets("担当別").Range("B2：B224")
Application.ScreenUpdating = False
For Each myC In myRng
wb(0).Sheets("回答雛型").Copy After:=wb(0).Sheets("回答雛型")
wb(0).Sheets("回答雛型 (2)").Name = "回答シート"
With wb(0).Sheets("DATA")
.AutoFilterMode = False
.Range("A1:J1").AutoFilter
.Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value 'D列
.Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy Sheets("回答シート").Range("A2")
.ShowAllData
x = wb(0).Sheets("回答シート").Cells(Rows.Count, "A").End(xlUp).Row
.Range("A823:J827").Copy wb(0).Sheets("回答シート").Range("A" & x + 1) '予備5行追加
End With
With wb(0).Sheets("回答シート")
.Rows(x + 6 & ":" & .Rows.Count).Delete Shift:=xlUp
Application.Goto Reference:=.Range("A1"), Scroll:=True
bcde = CStr(Trim(.Range("E2").Value))
sbfdr = Trim(.Range("G2").Value) 'サブフォルダ名
.Move
End With
Set wb(1) = ActiveWorkbook
SaveDir = wb(0).Path & "\20151114\" & sbfdr '保存先
If Dir(SaveDir, vbDirectory) = "" Then
MkDir SaveDir '無ければサブフォルダ作成
End If
DoEvents
wb(1).SaveAs Filename:=SaveDir & "\" & bcde & "_" & Trim(myC.Value) & ".xlsx"
wb(1).Close (False)
myC.Offset(, 1).Value = x - 1
i = i + 1
Application.StatusBar = i & "/" & myC.Value
Set wb(1) = Nothing
Next myC
Set wb(0) = Nothing
Application.ScreenUpdating = True
MsgBox i & "個のファイルを作成しました。" & vbCrLf & Format(Time - t, "hh:mm:ss")
Application.StatusBar = ""
End Sub
