エクセルファイルを一括でPDFに変換（再々）

質問

何度もの質問で失礼します。

実際にファイルのシート構成とやりたいことを整理（実際に試行）してみたら、
>https://okwave.jp/qa/q10028861.html　の>2022/07/12 22:18　回答No.3のご回答に、ファイル全体（全シート）をPDFに変換できるようにすれば完璧に動くことに気付きました。
ただし、A1：Z100までのセルが空白のシートは対象外。

実際の使い方としては添付図のように３つのケースで対応出来れば非常に効率的に作業できて良いのですが。

３つのケースで共通のルールは、
１．変換後はフルパスのフォルダの「ＰＤＦ変換」フォルダ（無ければ作成）に保存される。
２．A1:Z365までに文字と数字が入っていないシートは無視。

ケース別のルールは
１．フルパス、シート名、セル番地（例：Ｅ３のセル内容）をファイル名にして変換
２．フルパス、シート名のみ入っている場合は（Ｃ列を無視して）シート名までをファイル名で変換し保管
３．フルパスのみの場合は（空白シート無視で）全シート対象に変換

３つのケースがゴッチャになってしまって、プラス空白シートの無視が後知恵となって混乱しました。

上記でやりたいことが理解されることを期待します。

回答No.3

HohoPapa · ベストアンサー

こんなコードでいかかでしょうか。
お求めの内容は全数組み込んだつもりです。

Option Explicit

Dim ShCltl As Worksheet
Dim SeqNum As Long
Dim PdfDir As String

Const ChkRange = "A1:Z365"　'未使用か?を判断するセル範囲

'// ================= サンプル=================
Sub Sample()

　Const SRow = 2 'ブック一覧の開始行番号
　Dim RowNum As Long
　Dim tgBook As Workbook
　Dim tgSheet As Worksheet
　Dim shCnt As Long 'シート用カウンター

　Set ShCltl = ThisWorkbook.Sheets(1)
　RowNum = SRow
　SeqNum = 0　　　'ファイル名用連番を初期化
　Do
　　If ShCltl.Cells(RowNum, 1).Value = "" Then Exit Do

　　'出力先フォルダーのチェック、なかったら作成する
　　PdfDir = GetPath(ShCltl.Cells(RowNum, 1).Value) & "\PDF変換"
　　If IsExistDirA(PdfDir) = False Then
　　　MkDir PdfDir
　　End If

　　'ブックを開き、シートの数だけ繰り返し
　　Set tgBook = Workbooks.Open(FileName:=ShCltl.Cells(RowNum, 1).Value)
　　For shCnt = 1 To tgBook.Worksheets.Count
　　　If ShCltl.Cells(RowNum, 2).Value <> "" Then　'シートが指定されている場合
　　　　If tgBook.Sheets(shCnt).Name = ShCltl.Cells(RowNum, 2).Value Then
　　　　　ExportPDF RowNum, tgBook, tgBook.Sheets(shCnt)
　　　　End If
　　　Else
　　　　ExportPDF RowNum, tgBook, tgBook.Sheets(shCnt)
　　　End If
　　Next shCnt

　　tgBook.Close SaveChanges:=False　'ブックを閉じる
　　RowNum = RowNum + 1

　Loop

End Sub

'// =========PDFに書き出すサブルーチン========
Sub ExportPDF(RowNum As Long, tgBook As Workbook, tgSheet As Worksheet)

　Dim PutName As String

　'シートがバージンなら抜ける
　If IsVirgin(tgSheet, ChkRange) = True Then
　　Exit Sub
　End If

　SeqNum = SeqNum + 1　　　'ファイル名用連番をカウントアップ

　'出力ファイル名組み立て
　If ShCltl.Cells(RowNum, 3).Value <> "" Then
　　PutName = _
　　　　PdfDir & "\" & tgBook.Name & "_" & tgSheet.Name & "_" & _
　　　　tgSheet.Range(ShCltl.Cells(RowNum, 3).Value).Text & _
　　　　Format(SeqNum, "000000")
　Else
　　PutName = _
　　　　 PdfDir & "\" & tgBook.Name & "_" & tgSheet.Name & "_" & _
　　　　 Format(SeqNum, "000000")
　End If

　'PDF出力
　tgSheet.ExportAsFixedFormat Type:=xlTypePDF, _
　　 FileName:=PutName, _
　　 Quality:=xlQualityStandard, _
　　 IncludeDocProperties:=True, _
　　 IgnorePrintAreas:=False, _
　　 OpenAfterPublish:=False

End Sub

'// =========フォルダーの実在チェック========
Function IsExistDirA(a_sFolder As String) As Boolean
　Dim result
　result = Dir(a_sFolder, vbDirectory)
　If result = "" Then
　　IsExistDirA = False
　Else
　　IsExistDirA = True
　End If
End Function

'// ========フルパスからフォルダーを取得=======
Function GetPath(FullPath As String)
　Dim PathName As String, FileName As String, pos As Long
　pos = InStrRev(FullPath, "\")
　GetPath = Left(FullPath, pos)
End Function

'// =====シートが未使用かを判定する関数====
Function IsVirgin(tgSheet As Worksheet, Chk As String) As Boolean
　Dim rng As Range
　IsVirgin = True
　For Each rng In tgSheet.Range(Chk)
　　 If rng.Value <> "" Or rng.Formula <> "" Then
　　　　IsVirgin = False
　　　　Exit Function
　　 End If
　Next
End Function

なお、Ａ列に指定したブックが実在しない場合を考慮していません。

また、
>>https://okwave.jp/qa/q10024075.html のNo5の回答に
>A1:Z365に文字または数字の無いシートを無視するように追加することは可能でしょうか？
については、
現スレッドの課題が片付いたらポストします。
願わくば、片付いたことをはっきりさせるため、
あるいは、後々引用する場合に備え、
片付いたらクローズし、新たなスレッドとしてください。

お礼

毎度お世話になっております。
朝一で確認し、完璧でした！

最初から質問内容に漏れが無ければこれほどお手数をかけなかったハズと思うと何とも申し訳なく。
HohoPapaさんにとっては恐らく回答の作成より、要求事項の確認作業の方がハードルが高く、ストレスになったと推測致します。

えらいヨレヨレの船に乗りかかったと諦めて頂き 今少し（再再々）もよろしくお願い致します。

己のレベルの割に要求が高いことはご容赦！！

回答No.4

SI299792

やはり、エラーを想定しないのは、無理がありましたか。

①どのように止まるのですか。エラーメッセージ、エラーの出る行があったらいいです。

②A1:Z365 は、完全空白（数式などが入っていない）ですか（そう解釈しました）。それとも数式で空白になっている所があるのですか。

③可能なら、エラーになるワークブックを
データ便
https://www.datadeliver.net/
Officeオンライン
https://www.microsoft.com/ja-jp/microsoft-365/free-office-online-for-the-web
等に上げて下さい。

お礼

何度ものご回答に感謝です。
が、すでにこの一連の質問に最初からお助け頂いているNo3のご回答で、当初からの質問の不備に完璧に対応できましたので、何卒これ以上のSI299792さんの工数と知恵は次回の質問に温存しておいていただきたく。

ちなみに、止まった時に出るエラーMsgは「実行時エラー 1004、アプリケーション定義・・・」という私にとっては見慣れたいつものMsg内容です。
ご確認が有ったのでご参考までに。

回答No.2

SI299792

・入っているフォルダと同じフォルダに「ＰＤＦ変換」というフォルダを作って出力すればいいのですか。
・フルパス、シート名、セル番地
ファイル名が入っていません。
A2の場合
C:¥Users\Desktop\・・・・¥申請書・・・¥ＰＤＦ変換\原紙[C7]
になります。[C7]はC7の内容
ファイル名が無いので、フォルダ名とシート名が同じだと上書きされます。
・フォルダ・ファイル・シートが無いことを想定していません。無いとエラーで止まります。
Option Explicit
'
Sub Macro1()
Dim I As Worksheet
Dim RInp As Long
Dim File As Workbook
Dim FileName As String
Dim SheetName As String
Dim Address As String
Dim Sheet As Integer
Dim SheetT As Integer
'
Set I = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
'
For RInp = 2 To I.Cells(Rows.Count, "A").End(xlUp).Row
FileName = I.Cells(RInp, "A")
SheetName = I.Cells(RInp, "B")
Address = I.Cells(RInp, "C")
'
If I.Cells(RInp - 1, "A") <> FileName Then
On Error Resume Next
File.Close
On Error GoTo 0
Set File = Workbooks.Open(FileName, False, True)
End If
Sheet = 1
SheetT = Sheets.Count
'
If SheetName > "" Then
Sheet = Sheets(SheetName).Index
SheetT = Sheet
End If
'
For Sheet = Sheet To SheetT
Sheets(Sheet).Select
'
If WorksheetFunction.CountA([A1:Z365]) > 0 Then
FileName = File.Path & "\ＰＤＦ変換\"
On Error Resume Next
MkDir FileName
FileName = FileName & ActiveSheet.Name
FileName = FileName & Range(Address)
On Error GoTo 0
ActiveSheet.ExportAsFixedFormat xlTypePDF, FileName
End If
Next Sheet, RInp
On Error Resume Next
File.Close
On Error GoTo 0
End Sub

お礼

ご回答ありがとうございました。
お礼とお詫びです。

ご回答いただいたコードは試してみて、この質問内の課題は恐らく達成されています。1つのエクセルの2枚のシートはPDF変換されて指定の内に作成されたフォルダに保存されました。
が、1つ目のファイルで止まってしまいます。
恐らく変換対象の無い空白の「Sheet2」が原因だと思います（素人ながら）

この質問は、（再々）であり、上記のような種々のこちらの不手際（やりたいことの後付け）のために追加要求に次ぐ追加要求で３回目の仕切り直し（スレッド）です。

よって、SI299792さんに同じように最初に戻ってお手数をお掛けすることは心苦しく出来ませんので、ここまでとして頂きたく。

また、別の要求の再にはぜひともお助けください。
過去にも助けて頂いているので今後とも宜しくお願いします。
但し、レベルが低いわりに要求が多く、おまけに質問内容に抜けが多い質問者ですので根気と忖度が要求されること予めご了承ください。

あるご回答者まさまからは回答の数倍の叱責を頂くことも多く反省はするのですがレベルは上がらず・・・

回答No.1

HohoPapa

>１．フルパス、シート名、セル番地（例：Ｅ３のセル内容）をファイル名にして変換

フルパスには、￥、:が含まれますが、これらはファイル名に使うことができません。
フルパス、シート名をsample表示し、
ファイル名を例示してみてください。

>フルパスのみの場合は（空白シート無視で）全シート対象に変換
これは予想外の要求です。
キナガに待つか、識者のコメントに期待してください。

２．フルパス、シート名のみ入っている場合は（Ｃ列を無視して）シート名までをファイル名で変換し保管
３．フルパスのみの場合は（空白シート無視で）全シート対象に変換

お礼

前の質問に対するご回答のコードを改めて確認してみました。

最初に頂いた
＞https://okwave.jp/qa/q10024075.html のNo5の回答に
A1:Z365に文字または数字の無いシートを無視するように追加することは可能でしょうか？
この改良版と、
＞https://okwave.jp/qa/q10028861.html　のNo.3のご回答
の2つあればケースによって使い分ければ目的は100%達成なのですが。

補足

またまた、やってしまいました。
>１．フルパス、・・・をファイル名にして・・・
全くの大ボケで、PDFのファイル名は従来通り、エクセルのファイル名＋シート名＋指定セルの内容＋連番、の意図でした。

>フルパスのみの場合は（空白シート無視で）全シート対象に変換
これは前の質問、
https://okwave.jp/qa/q10024075.htmlに対するNo5の回答でコードで指定したフォルダ内のエクセルファイル（Book）を対象に空白シートも含めて全シートをPDFに変換できたと思っているのですが。。

これを空白シートは無視も別回答
https://okwave.jp/qa/q10028861.html の No3で、

＞Option Explicit
Dim ShCltl As Worksheet
Dim SeqNum As Long

Const ChkRange = "A1:Z365"　'未使用か?を判断するセル範囲
・・・・
で達成できていると思っているのですが、もしこの解決に多くの工数がかかるならこれは無視で全くかまいません。
こちらも少しは手間暇かけるのは当然ですので。
（ということは本件すでに解決済み？）

ストレスをおかけしていること申し訳なく・・・