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

HohoPapa

>Sub TEST20201015() '2020/10/15これが一番か
このコード場合、移動先に同名のファイルがあるとエラーになってしまいます。
エラーになったほうがいいのであれば別ですが、
同名のファイルがあった場合は、上書きする動作とするのであれ、
複写のほうが無難だろうと思います。

一方、
>「実行時エラ75：パス名が無効です」
といったエラーになるのは、純粋に環境の問題であって
MoveFileだから今後は起きないという保証はないだろうと思います。

そこで、
>Sub TEST20201015() '2020/10/15これが一番か
をベースに、
複写して複写元を削除するコードと
複写先を削除して、移動するコードを
エラーの場合には指定回繰り返す（挑戦する）仕様で書いてみました。
後記に2案あります。

当方ではエラーが起きないので
エラーが起きる場合の動作テストはしていませんが
よかったら試してみてください。

なお、削除を追加したことで
せっかくでなくなった
>「実行時エラ75：パス名が無効です」
がまた起きるようになるかもしれません。

'//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:
　MsgBox Format(ErrCnt, "0") & "回目のエラー: " & f
　ErrCnt = ErrCnt + 1
　If ErrCnt > Border Then Resume Next
　Resume
End Sub

'//////////////////////////////////////////////////////////////

'//copy（複写）してKill（削除）　再試行付き--------------------
Sub TEST05()
'「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"
　　　TryCopy MyTemp & "\" & Fn & ".pdf", fdr & "\" & Fn & ".pdf"
　　　On Error Resume Next
　　　Kill MyTemp & "\" & Fn & ".pdf"
　　　On Error GoTo 0
　　Next n
　End With
　Application.StatusBar = ""
End Sub

Sub TryCopy(f As String, t As String)
　Dim ErrCnt As Long
　Const Border = 5　　　'再試行回数
　On Error GoTo ErrLabel
　ErrCnt = 0
　FileCopy f, t
　Exit Sub
ErrLabel:
　MsgBox Format(ErrCnt, "0") & "回目のエラー: " & f
　ErrCnt = ErrCnt + 1
　If ErrCnt > Border Then Resume Next
　Resume
End Sub

お礼

何度もありがとうございます。
'//fsoで移動 再試行付きSub TEST07()　はFSO.DeleteFile fで全件、「実行時エラー53：ファイルが見つかりません」ないというエラーになります。
FSO.DeleteFile f　をコメントアウトしてみたら全件OKです。

'//copy（複写）してKill（削除）　再試行付きSub TEST05()は何度もMsgBox Format(ErrCnt, "0") & "回目のエラー　を繰り返しながらも最後まで行きます。
On Error GoTo ErrLabelをコメントアウトしてみたらやはり、パスが見当たりませんのエラーでした。

やはりCopyはやめておいて移動がいいのかなと思いますが、同名のファイル（通常はないはずですがあれば面倒なので）の対策を入れて下記のようにしてみました。
ご指導いただければ幸いです。

Sub TEST20201019() '2020/10/19 同名ファイル対策済み
'「Microsoft Scripting Runtime」を参照設定
　　Dim fdr As String, Fn As String
　　Dim n As Long
　　Dim src As String, MyTemp As String
　　Dim t As Single
　　Dim myFileSystem As New Scripting.FileSystemObject

　　t = Timer
　　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 & "件目"
　　　　　　src = MyTemp & "\" & Fn & ".pdf"
　　　　　　ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=src

　　　　　　If Dir(fdr & "\" & Fn & ".pdf") <> "" Then '同じ名前のファイルがあれば
　　　　　　　　Kill fdr & "\" & Fn & ".pdf" ' 先にファイルを削除する
　　　　　　End If

　　　　　　Call myFileSystem.MoveFile(src, fdr & "\") '// ファイルを移動
　　　　Next n
　　End With
　　Application.StatusBar = ""
　　MsgBox "" & (Timer - t) \ 60 & "分" & (Timer - t) Mod 60 & "秒を要しました。"
End Sub

回答No.13

masnoske

No.12 です．
FSOの使い方は色々あります．
教科書通りであれば，FSOをオブジェクト変数として定義し CreateObjectで設定するという使い方です．
最後は行儀良く Set FSO = Nothing ですね．

私はその一連の設定が面倒なので With～End Withで，その場で FSO使い捨てる使用方法をしています．

どちらを採用するかは，個人の好みで良いと思います（それが VBAの良いところでもあり悪いところでも）．

お礼

ご丁寧にありがとうございます。
ご指導にとても感謝いたします。
これからもよろしくお願いいたします。
とても助かりました。

回答No.12

masnoske

No.11です．
エラーが起きるかも知れないので，
誤：.MoveFile src, Fdr
正：.MoveFile src, Fdr & "\"

お礼

はい、ありがとうございます。このようにいたしました。

補足

いろいろやっていて、端末内での処理はやはりテンポラリーフォルダーがよいのではと思いました。それで回答No9のHohoPapaさんのと組みあわせて以下のようにしてみました。一応ちゃんと動いているのですが、自信がありません。なんせFileSystemObjectはつかったことがありませんので。大変申し訳ないのですがみていただけないでしょうか？

Sub TEST20201015() '2020/10/15これが一番か

'「Microsoft Scripting Runtime」を参照設定

　　Dim Fdr As String, Fn As String

　　Dim n As Long

　　Dim src As String, MyTemp As String

　　Dim t As Single

　　Dim myFileSystem As New Scripting.FileSystemObject

　　t = Timer

　　MyTemp = myFileSystem.GetSpecialFolder(TemporaryFolder)

　　With Sheets("Test")

　　　　.Activate

　　　　Fdr = ThisWorkbook.Path & "\" & Format(Date, "YYYYMMDD") & "-test"　'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 & "件目"

　　　　　　src = MyTemp & "\" & Fn & ".pdf"

　　　　　　ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=src

　　　　　　Call myFileSystem.MoveFile(src, Fdr & "\") ' ファイルを移動

　　　　Next n

　　End With

　　Application.StatusBar = ""

　　MsgBox "" & (Timer - t) \ 60 & "分" & (Timer - t) Mod 60 & "秒を要しました。"

End Sub

回答No.11

masnoske

No.8です．
ローカルからサーバへのコピーがOKなら，

Sub TEST01() '2020/10/13
Const tmpFdr As String = "D:\temp" ' ご自分で設定して下さい

Dim Fdr As String, Fn As String
Dim n As Long
Dim src As String

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 & "件目"
src = tmpFdr & "\" & Fn & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=src
With CreateObject("Scripting.FileSystemObject")
.MoveFile src, Fdr
End With
Next n
End With
Application.StatusBar = ""
End Sub

これでOKなら，ベストアンサーは No.3の方に．

お礼

ありがとうございます！
エラーも出ず、20件のテストデータが1分6秒でPDFで出力されました。
.MoveFile だけで、自分の端末内のデータは消えるんですね！知りませんでした。ありがとうございます。

回答No.10

kkkkkm

横から失礼

> 今20件のデータでためしたところ、4件目で「実行時エラ75：パス名が無効です」とでて止まってしまいました。

ダメ出しをしていますが、No3のお礼「ただ今回はサーバー内でという条件付きなのです。」のでしたら「ローカルなＰＣのテンポラリーなフォルダーに書き出しでの操作」の手直しは無駄な努力を強いている事になりませんか？

お礼

ご指摘ありがとうございます。
kkkkkmさんから「いったんローカルに全て保存して、それをサーバーに移動するVBAにすればどうなんでしょう。」とアドバイスをいただいたとき、あまり頭のまわらないわたしは、自分の端末内に保存したものをサーバーに移動すれば、端末内にデータが残ってしまうと誤解してしまいました。ところがHohoPapaさんの方法では、端末内で作成する都度、自動で消しているようなのでこれはいけるのでは！と思ったわけです。
ご気分を害されたのならお詫びいたします。ありがとうございました。

回答No.9

HohoPapa

>ただ、フォルダー内に無用のtmpファイルが5つできていました。
といった症状からも

>>サーバー側のセキュリティーソフト、あるいは
>>サーバー側の常駐アプリが悪さし、
>>このテンポラリーなファイルを一定時間開放しない
>>可能性はありませんでしょうか。
が濃厚な気がします。

それが、課題サーバー上の障害なのか、制限事項なのかはわかりませんが、
サーバーですから、ミラーや諸々の監視、
RAIDといった冗長化が行われている可能性があり、
それらのいづれかがタコな可能性もありましょう。

一方、
・このサーバー側の問題には触れない
・Windows7でいく
・マクロブックはサーバーに配置する。
・マクロブックは、ローカルなＰＣで実行する
・PDFファイルは、ファイルサーバーに保存する
といった条件を満足させるのであれば
私なら、

サーバー上に配置したマクロブックを
ローカルなＰＣで実行するものの、
ＰＤＦファイルは一時的にローカルなＰＣのテンポラリーなフォルダーに書き出し
書き出す都度、ファイルサーバー上に複写し
テンポラリーなフォルダー上のファイルは削除する

といった制御にします。

以下がサンプルコードです。
なお、「Microsoft Scripting Runtime」を参照設定する必要があります。

Sub TEST04()
'「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:=Fdr & "\" & Fn & ".pdf"
　　　　　　ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=MyTemp & "\" & Fn & ".pdf"
　　　　　　FileCopy MyTemp & "\" & Fn & ".pdf", Fdr & "\" & Fn & ".pdf"
　　　　　　On Error Resume Next
　　　　　　Kill MyTemp & "\" & Fn & ".pdf"
　　　　　　On Error GoTo 0
　　　　Next n
　　End With
　　Application.StatusBar = ""
End Sub

お礼

なんどもありがとうございます。
今20件のデータでためしたところ、4件目で「実行時エラ75：パス名が無効です」とでて止まってしまいました。
フォルダー内には4件目までPDFはできており、PDFとして正常に開くことができます。

補足

Sub TEST20201015()
'「Microsoft Scripting Runtime」を参照設定
　　Dim Fdr As String, Fn As String
　　Dim n As Long
　　Dim src As String, MyTemp As String
　　Dim t As Single
　　Dim myFileSystem As New Scripting.FileSystemObject

　　t = Timer
　　MyTemp = myFileSystem.GetSpecialFolder(TemporaryFolder)

　　With Sheets("Test")
　　　　.Activate
　　　　Fdr = ThisWorkbook.Path & "\" & Format(Date, "YYYYMMDD") & "-test"　'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 & "件目"
　　　　　　src = MyTemp & "\" & Fn & ".pdf"
　　　　　　ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=src
　　　　　　Call myFileSystem.MoveFile(src, Fdr & "\") ' ファイルを移動
　　　　Next n
　　End With
　　Application.StatusBar = ""
　　MsgBox "" & (Timer - t) \ 60 & "分" & (Timer - t) Mod 60 & "秒を要しました。"
End Sub

回答No.8

masnoske

No.6です。
以下の行をコメントアウトすると早くなるかも知れません。
Application.Wait Now() + TimeValue("00:00:01") '1秒PDF保存完了を待つ

ですが No.3の方が書かれているように、ローカルにpdfファイルを作成し、サーバーに移動するのが素直なように思います。

お礼

コメントアウトしてみましたが6分台でした。ありがとうございました。

回答No.7

HohoPapa

起きている現象に興味を惹かれ、
当方環境のファイルサーバー上で実行してみましたが現象が起きません。
また、
トラフィックやサーバーの性能などが過酷な環境でも現象を起こすことができません。

そもそも、同じファイル名で連続して書くことさえなければ、
１つのファイルに複数回アクセスする動作はないでしょうから
排他の問題は起きないだろうと思うのです。

エクセルの場合、PDFに出力する場合であっても、
（またエクセルブックを保存する場合であっても）
指定したファイル名でいきなり保存するのではなく
テンポラリーなファイル名で保存し、
これを指定したファイル名にリネイムする動作をします。

サーバー側のセキュリティーソフト、あるいは
サーバー側の常駐アプリが悪さし、
このテンポラリーなファイルを一定時間開放しない可能性はありませんでしょうか。

それでも改善しないようであれば
私だったら、
PDFに保存（エクスポート）するのではなく、
後記コードのように、印刷する先を
"Microsoft Print to PDF"など、
PDFファイルに出力するプリンタードライバーにします。

Sub TEST03()
　Dim Fdr As String, Fn As String
　Dim n As Long
　Dim PutFileName As String

　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 & "件目"

　　　PutFileName = Fdr & "\" & Fn & ".pdf"
　　　On Error Resume Next
　　　Kill PutFileName
　　　On Error GoTo 0

　　　ActiveWindow.SelectedSheets.PrintOut _
　　　　ActivePrinter:="Microsoft Print to PDF", _
　　　　PrintToFile:=True, PrToFileName:=PutFileName
　　Next n
　End With
　Application.StatusBar = ""
End Sub

お礼

すばらしいアイデアとコードをありがとうございます！
ただ、残念なことに社内はまだWindows10になっていません。そのせいなのでしょうが"Microsoft Print to PDF"を指定すると、エラーなくPDFは高速でできるのですが、できたPDFはファイルが破損しているとなって開けません。残念です。

補足

Windows10でなくともやる方法はと考え、
ActivePrinter:="Microsoft Print to PDF"　をWindows7でもOKの
ActivePrinter:="Microsoft XPS Document Writer"　にし、拡張子をxpsに変えてみました。
成功です！あっというまに20件出来上がりです！
問題は、PDFでという上司がXPSですんなりOKするかどうかですが。わたしもXPSなんて使うのは初めてです。

回答No.6

masnoske

No.4，No.5です．
あまり良い方法ではありませんが，エラートラップを直接掛けてみてはどうでしょうか．
下手すると無限ループに入ってしまいますので，10秒以上応答がない場合は強制終了させて下さい．
一応 1004以外のエラーが起きた場合は停止するようにしてあります．

Sub TEST01() '2020/10/11
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

On Error GoTo ErrTrap
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"
Next n
On Error GoTo 0
End With
Application.StatusBar = ""
Exit Sub

ErrTrap:
If Err.Number = 1004 Then
Application.Wait Now() + TimeValue("00:00:01") '1秒PDF保存完了を待つ
Resume
Else
MsgBox "エラー " & Err.Number & " が発生しました．"
On Error GoTo 0
End If
End Sub

お礼

本当になんどもありがとうございます。
20件のデータをためしたところエラーはでずにうまくいきました。ただ、フォルダー内に無用のtmpファイルが5つできていました。また所要時間が9分1秒でした。
10秒PDF保存完了を待つ方法では同じデータで4分13秒でしたので倍以上かかってしまいます。

回答No.5

masnoske

サーバー側のフォルダ設定で解決したという情報がありました．
https://teratail.com/questions/124283

お礼

フォルダーの種類を「一般項目」から「ドキュメント」に変更しましたが結果はおなじでした。
なんどもありがとうございました。