こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

エクセルVBAでファイル保存失敗の原因?

エクセル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

投稿日時 - 2015-11-14 10:21:16

QNo.9080025

すぐに回答ほしいです

質問者が選んだベストアンサー

> Sheets("回答雛型")のCopy&Moveをやめ、雛形はあらかじめ別のファイルとして作成しといて、これに抽出データを張り付け、SaveCopyAsで別名保存させる方法をとりました。

テンプレートブック(.xltx)を用意しておいて、
Workbooks.Add Template:= ... や Sheets.Add Type:= 等で開くようにするのが、
Excelでは標準的に用意された方法として無難(トラブル少ない)です。

> これだと、何度も繰り返して試しましたが今のところエラーは出ませんでした。

解決の道筋として正しい方向だと思いますから、
エラーの探究については、最早重要ではないですね。

一応、、、。
今回用意したダミーサンプルで、worksheet.Move メソッドのおかしな挙動を見つけました。
ご提示のマクロをステップ実行で確かめていたら、偶然、
.Moveの直後に、A:J列に設定してある塗りつぶしが、
1行めから追加の5行までの範囲で、勝手に行全体に拡張してしまうのを確認しました。
この現象はVBAだけではなく、手作業でも、.copy → .move した時にも確認できました。
.copy してブックを保存して閉じてしまえば、.copy されたシートを .move しても、
再現されませんでした。
ただ、どのような書式設定をすれば、(塗りつぶしだけではなさそう)
この現象を再現できるのか、という詳細までは未確認ですが、
今の処、複数のブック、シートで何度でも必ず発生している現象です。
一応、報告まで。

> 今回、ご教示いただいたコードはまだ解読できておりませんが、勉強したいと思います。

.SaveCopyAs してから workbooks.Open → 編集 → workbook.Close (True)
というやり方が、二度手間のようにも見えますが、
結構高速だったりする(テンプレートブックを開くよりも軽かったです)ので、
#1でお話の雛形ブックの扱いの参考になればなぁ、と思ったくらいで、
何処となくネタっぽく見えてしまうような設計だな、とは私も感じていますし、
適当に流してくださって結構ですので。適当に、、、。

それではまた。

投稿日時 - 2015-11-21 00:08:22

お礼

何度もありがとうございます。

> 今回用意したダミーサンプルで、worksheet.Move メソッドのおかしな挙動を見つけました。

やはり、WorksheetのCopy & Moveは使わないほがいいですね。以後気をつけるようにします。
これからもご指導ください。
ありがとございました。

投稿日時 - 2015-11-21 09:36:07

このQ&Aは役に立ちましたか?

2人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.2

こんにちは。回答お休み中でした。もう終わっちゃったかな?

>.どんな問題.?
設計上の過不足があるとか、
環境に合わない方法を採っているとか、
ひょっとして何時かのkbのバグによるとか、
色んな可能性が想像できます。
コードから読み解いたイメージを基に
テスト用の簡単なダミーサンプルを作って、
ご提示のコードを試してはみたものの、
こちらでは状況を再現出来ませんでした。
直球の問題解決については現状では語れないです。

セルの値と[セルの書式]以外にもコピーしたいものがあるからこそ、
worksheet.Copy や range.Copy を使っているのでしょうけれど、
コピーしたい中身にはどんものが含まれるのか、
 コメント?写真等のシェイプ/オブジェクト?条件付き書式?入力規則?ハイパーリンク?....?
ここら辺が解れば、何が必要でどうすれば十分なのか明るくなって、
多少は問題点の切り分けもし易くなるのかも。
他にはハードディスク等の媒体やOS、IE、常駐アプリなんかも影響を無視できない?
tempフォルダに残った一時ファイルが影響しているケースとかも考えて、tempフォルダ掃除してみるとか?
苦い経験を思い返してみると、
セル範囲削除を繰り返したり、
ExcelやVBEで名前を管理しているオブジェクト(シート/ブック含む)のLoad/Unloadを繰り返したり、
条件付き書式の切り貼りを繰り返したり、
ご提示のような処理の場合だとVBEを開いたまま実行したり、
等についても一度は原因として疑ってみようかなぁとか。。

問題がはっきりしないままですが上述への対策のつもりで、
動くものを(パーツ紹介的に)書いてみました。
ザックリと、
雛型シートを基に、データ貼り付け以外のすべての処理、を済ませたブック
を作成しExcelブック(.xlsx)としてそのまま保存し、
閉じずに開いたままにしておいたものを雛型として
.SaveCopyAsで(開かずに)保存して、次いで開いて、
必要なデータを貼り付けたら、閉じながら上書きする。
という流れです。
フィルター抽出されたレコード件数が共通であれば、
データ貼り付け以外の処理はすべて共通、という解釈で、
レコード件数ごとに共通の雛型を作るようにして、
負荷の大きい処理を軽減します。
先回のご質問で拘ってらっしゃった(?)
ActiveWorkbook や ActiveSheet
を扱うので(実行中のユーザー操作の影響回避)、
Application.Interactive = False で実行します。
未完のプロットですので、もしエラーで中断した時は、そのまま終了させないで、
最後の10行だけでも実行し復旧させるように扱ってください。

何か過不足があったとして、補足を頂いても即応出来そうもないのですが、
多少は気長に考えられるようでしたら、可能な限り応答しようと思っています。


Sub W9080025a()
Dim wksSrc As Worksheet, wksMaster As Worksheet
Dim rngSrc As Range, rngCopySrc As Range, rngList As Range, c As Range
Dim arrMotherWbk(), vTmp
Dim sParentDir As String, sSubDir As String, sCode As String, sNewPath As String
Dim t As Single
Dim cnRec As Long, cnFiles As Long
t = Timer()

With ThisWorkbook
 Set wksSrc = .Sheets("DATA")
 Set rngList = .Sheets("担当別").Range("B2:B224")
 Set wksMaster = .Sheets("回答雛型")
 sParentDir = .Path & "\20151114" ' 保存先 親フォルダ
End With
With Application
 .ScreenUpdating = False
 .Interactive = False
 .EnableEvents = False
 .Calculation = xlCalculationManual
 .CalculateBeforeSave = False
 .Goto wksMaster.Cells(1)
End With

If Dir(sParentDir, vbDirectory) = "" Then
 MkDir sParentDir ' 無ければ親フォルダ作成
End If
sParentDir = sParentDir & "\"

wksSrc.AutoFilterMode = False
With wksSrc.Cells.CurrentRegion
 Set rngSrc = .Columns("D") ' 検索対象 D列
 Set rngCopySrc = .Offset(1).Resize(.Rows.Count - 1) ' コピー元 D列 タイトル除くレコード範囲
End With

ReDim arrMotherWbk(1 To 10) As Variant

For Each c In rngList
 vTmp = c
 cnFiles = cnFiles + 1
 Application.StatusBar = cnFiles & " / " & Trim(vTmp)

 rngSrc.AutoFilter Field:=1, Criteria1:=vTmp
 cnRec = WorksheetFunction.Subtotal(3, rngSrc) - 1
 c.Offset(, 1).Value = cnRec

 If cnRec Then
  With rngSrc.Find(What:=vTmp)
   sCode = Trim(.Offset(, 1))
   sSubDir = sParentDir & Trim(.Offset(, 4)) ' サブフォルダ名 ' 保存先
  End With
  If Dir(sSubDir, vbDirectory) = "" Then
   MkDir sSubDir ' 無ければサブフォルダ作成
  End If
  sNewPath = sSubDir & "\" & sCode & "_" & Trim(vTmp) & ".xlsx"

  If cnRec > UBound(arrMotherWbk()) Then ReDim Preserve arrMotherWbk(1 To cnRec)
  If Not IsObject(arrMotherWbk(cnRec)) Then
   wksMaster.Copy
   ActiveSheet.Name = "回答シート"
   Rows(cnRec + 7 & ":" & Rows.Count).Delete xlUp
   wksSrc.Range("A823:J827").Copy Cells(cnRec + 2, "A") ' 予備5行追加 コピー元?要確認
   DoEvents
   ActiveWorkbook.SaveAs Filename:=sParentDir & "mother" & cnFiles, FileFormat:=xlOpenXMLWorkbook
   Set arrMotherWbk(cnRec) = ActiveWorkbook
  End If

  arrMotherWbk(cnRec).SaveCopyAs Filename:=sNewPath
  Workbooks.Open Filename:=sNewPath
  rngCopySrc.Copy Cells(2, "A")
  ActiveWorkbook.Close (True)
 End If
Next

rngList.Worksheet.Activate
Set rngList = Nothing: Set rngSrc = Nothing: Set rngCopySrc = Nothing
wksSrc.AutoFilterMode = False
Set wksMaster = Nothing: Set wksSrc = Nothing
For Each vTmp In arrMotherWbk()
 If IsObject(vTmp) Then
  sNewPath = vTmp.FullName
  vTmp.Close (False)
  Kill sNewPath
 End If
Next
Erase arrMotherWbk()

With Application
 .StatusBar = ""
 .CalculateBeforeSave = True
 .Calculation = xlCalculationAutomatic
 .EnableEvents = True
 .Interactive = True
 .ScreenUpdating = True
End With

MsgBox cnFiles & "個のファイルを作成しました。" & vbCrLf & Round(Timer - t, 1) & " sec."

End Sub

投稿日時 - 2015-11-20 09:33:34

お礼

realbeatinさん、いつもありがとうございます。

> セルの値と[セルの書式]以外にもコピーしたいものがあるからこそ、
> worksheet.Copy や range.Copy を使っているのでしょうけれど、

はい、あります。
余白や用紙の縦横向きなどのページ設定です。
これは、新たにVBAで設定しようとすると他の作業にくらべ遅いです。それで大量のファイルを作成するのには時間がかかりすぎるのでシートのコピーを行ってました。range.Copy は入力規則のコピーです。
でもあまりに不安定で、以前、realbeatinさんが
http://okwave.jp/qa/q9070896.html
で、「シートそのものをVBAでコピーする、ということには個人的に消極的です。」とお書きだったのを思い出し、わたしも今回は回答No1さんへのお礼でも書いたとおり、Sheets("回答雛型")のCopy&Moveをやめ、雛形はあらかじめ別のファイルとして作成しといて、これに抽出データを張り付け、SaveCopyAsで別名保存させる方法をとりました。
これだと、何度も繰り返して試しましたが今のところエラーは出ませんでした。
今回、ご教示いただいたコードはまだ解読できておりませんが、勉強したいと思います。
ありがとうございました。

投稿日時 - 2015-11-20 22:49:35

ANo.1

こんにちは
wb(1).SaveAs Filename:=SaveDir & "\" & bcde & "_" & Trim(myC.Value) & ".xlsx"
を、
wb(1).SaveAs Filename:=SaveDir & "\" & bcde & "_" & Trim(myC.Value) & ".xlsx"", _
FileFormat:=xlOpenXMLWorkbook
とすると、どうでしょうか?

投稿日時 - 2015-11-17 15:30:36

お礼

ご回答ありがとうございます。
早速試しました。
1回目はエラーがです、223ファイルすべて成功しました。
しかし、2回目のテストは84ファイル目で同じエラーメッセージが出てしまいました。
残念です。
もう時間がありませんので他の方法でいきたいと思ってます。
具体的には、Sheets("回答雛型")のCopy&Moveをやめ、雛形はあらかじめ別のファイルとして置き、これに抽出データを張り付け、別名で保存させる方法です。

これだと、何度か繰り返して試しましたが今のところエラーは出ないようです。

投稿日時 - 2015-11-17 18:17:51

あなたにオススメの質問