エクセルVBAでPDF保存ができません

質問

エクセルのシートを連続してPDFで出力するVBAで困っています。
自分の端末内で動かす分にはぜんぜん問題はありません。ところが会社のサーバー内の共有フォルダーに保存して動かすと、最初の1件だけは正常にPDFに保存されますが、何度やっても２件目でエラーになりPDFが保存されません。
「実行時エラー1004　ドキュメントを保存できませんでした。ドキュメントが開いているか、保存時にエラーが発生した可能性があります。」
となってしまうのです。

PDFが保存されないうちに次のPDFを作成して保存しているためかと思いApplication.Waitで10秒待つようにしたところ最後まで保存ができました。
しかし、自分の端末内ではWaitを入れなくとも問題なくできます。

質問は、この原因と、一律にApplication.Waitで10秒待たなくとも別の方法で対応する方法はないかということです。
よろしくお願いいたします。

Sub TEST01() '2020/10/10
　　Dim Fdr As String, Fn As String
　　Dim n As Long

　　With Sheets("Test")
　　　　.Activate
　　　　Fdr = ThisWorkbook.Path & "\" & Format(Date, "YYYYMMDD") & "-PDF"　'PDF保存先'
　　　　If Dir(Fdr, vbDirectory) = "" Then
　　　　　　 MkDir Fdr '無ければ作成
　　　　End If

　　　　For n = 1 To 20
　　　　　　.Range("C5").Value = Sheets("Data").Cells(n, "A").Value
　　　　　　Fn = .Range("C5").Value & "_" & .Range("D5").Value　　'ファイル名
　　　　　　Application.StatusBar = Fn & " PDFファイル作成中/" & n & "件目"
　　　　　　ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fdr & "\" & Fn & ".pdf"
　　　　　　Application.Wait Now() + TimeValue("00:00:10")　　 '10秒PDF保存完了を待つ（1-8秒では保存エラー）
　　　　Next n
　　End With
　　Application.StatusBar = ""
End Sub

回答No.15

HohoPapa · ベストアンサー

ごめんなさい、
ファイルがない場合にFSO.DeleteFileがエラーになることを考慮していなかったです。

ぶっちゃけ、
Sub TEST20201019() '2020/10/19 同名ファイル対策済み
このコードで安定しているならそれでもいいと思いますが、
なにしろ、ないやら問題ありな環境と思われることから
もう少し丈夫なコード
（エラーが出ても、何度かはリトライするコード）
が望まれるだろうと思うのです。

そこで、
存在しないファイルを削除する場合のエラーはスルーし、
それ以外のエラーの場合には、指定回数再試行する。
指定回数を超えたらエラーメッセージを表示して
次のステップに進む。
というコードにしてみました。

よかったら試してみてください。

'//fsoで移動 再試行付き　--------------------
Sub TEST07()
'「Microsoft Scripting Runtime」を参照設定
　Dim fdr As String, Fn As String
　Dim n As Long
　Dim myFileSystem As New Scripting.FileSystemObject
　Dim MyTemp As String
　MyTemp = myFileSystem.GetSpecialFolder(TemporaryFolder)

　With Sheets("Test")
　　.Activate
　　fdr = ThisWorkbook.Path & "\" & Format(Date, "YYYYMMDD") & "-PDF"　'PDF保存先'
　　If Dir(fdr, vbDirectory) = "" Then
　　　 MkDir fdr '無ければ作成
　　End If

　　For n = 1 To 20
　　　.Range("C5").Value = Sheets("Data").Cells(n, "A").Value
　　　Fn = .Range("C5").Value & "_" & .Range("D5").Value　　'ファイル名
　　　Application.StatusBar = Fn & " PDFファイル作成中/" & n & "件目"
　　　ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=MyTemp & "\" & Fn & ".pdf"
　　　TryMove fdr & "\" & Fn & ".pdf", MyTemp & "\" & Fn & ".pdf", fdr & "\"
　　Next n
　End With
　Application.StatusBar = ""
End Sub

Sub TryMove(f As String, t As String, fdr As String)
　Dim ErrCnt As Long
　Dim FSO As Object
　Set FSO = CreateObject("Scripting.FileSystemObject")
　Const Border = 5　　　'再試行回数
　On Error GoTo ErrLabel
　ErrCnt = 0
　　　FSO.DeleteFile f
　　　FSO.MoveFile t, fdr & "\"
　Set FSO = Nothing
　Exit Sub
ErrLabel:
　If Err.Number = 53 Then Resume Next
　ErrCnt = ErrCnt + 1
　If ErrCnt > Border Then
　　MsgBox "エラーが限界回数を超過" & f
　End If
　Resume
End Sub

繰り返しますが、当方ではエラーが出ないので
エラーが起きる場合の動作確認はしていません。

お礼

HohoPapaさん、ほんとに最後までお付き合いくださいましてもう感謝の気持ちでいっぱいです。
ご教示のコードで問題なく全件作成できました！
20件で58秒ですので時間もかかりません。
これで安心して上司に完成を報告できます。
ありがとうございました。

回答No.4

masnoske

No.2です．
同じ結果になるかも知れませんが，Dirではなく FSOを使ってみてはどうでしょうか．

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fdr & "\" & Fn & ".pdf"

Set myFile = Nothing
With CreateObject("Scripting.FileSystemObject")
Do While myFile Is Nothing
Application.Wait Now() + TimeValue("00:00:01")　　 '1秒PDF保存完了を待つ
On Error Resume Next
Set myFile = .GetFile(Fdr & "\" & Fn & ".pdf")
On Error GoTo 0
Loop
End With
Set myFile = Nothing

お礼

なんどもありがとうございます。
やってみましたが結果は同じでした。

回答No.3

kkkkkm

> 別の方法で対応する方法

結果は同じ(エラーになる)かもしれませんが、いったんローカルに全て保存して、それをサーバーに移動するVBAにすればどうなんでしょう。

お礼

ありがとうございます。ただ今回はサーバー内でという条件付きなのです。

回答No.2

masnoske

No.1 です．
Application.Wait Now() + TimeValue("00:00:10")　　 '10秒PDF保存完了を待つ（1-8秒では保存エラー）
この部分を以下のようにループ処理します．
Do While Dir(Fdr & "\" & Fn & ".pdf") = ""
Application.Wait Now() + TimeValue("00:00:01")　　 '1秒PDF保存完了を待つ
Loop

お礼

ありがとうございます。
早速以下のようにやってみました。
Do While Dir(Fdr & "\" & Fn & ".pdf") = ""
　　Application.Wait Now() + TimeValue("00:00:01")　　 '1秒PDF保存完了を待つ
　　ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fdr & "\" & Fn & ".pdf"
Loop
ところが同じエラーが出ます。
フォルダを見るとPDFファイルはできています。しかしファイルサイズが 0KB で、「ファイルが破損している」となってこれをひらくことはできませんでした。

補足

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fdr & "\" & Fn & ".pdf"
Do While Dir(Fdr & "\" & Fn & ".pdf") = ""
　　Application.Wait Now() + TimeValue("00:00:01")　　 '1秒PDF保存完了を待つ
Loop

でもダメでした。

回答No.1

masnoske

サーバー側の処理が終わる前に次の作業に移るのが原因でしょう。
タイミングの問題なので何秒待てば良いという答えはありません（10秒待てば十分だとは思いますが）。
待ち時間がもったいないのであれば、書き込み処理のあと、そのファイルがサーバーで見つかるまでループで待てば良いと思います。

お礼

ありがとうございます。