フォルダ内のエクセルを一括でｐｄｆに変換（再）

質問

6/27に表題の質問をさせていただいて、7/7にご回答を頂いて使い始めたのですが、実際のエクセルファイルには想定外の問題があり、何とか改善していただけないかと、再（追加）のお願いです。
「出来ることなら」ベースのお願いです。

何度もの追加要求で、結局2つのコードをご回答いただいたのですが、10個程度の試行検証では気付かなかった古いファイル（これが最初の対象エクセルファイル）でのシートの不整合が発覚しました。

ご回答で何とか200程度のファイルは処理したのですが非常に作業効率が悪いので出来れば改善をお願いしたく・・・・

１．フォルダ内ファイルの一括変換コード
Book内にデフォルトで空白のSheet2、Sheet3がくっついたファイルが一定頻度で存在していました。
空白のシートはPDFで「開けないファイル」とエラが出るのでシートが空白であることの確認ができない。

●改善点：空白のシートは無視できませんか？

２．シート名指定の変換コード
シート名を「申請書」に統一してあるのですが、シート名が入っていない「Sheet1」のエクセルファイルが一定の確率で入っており、該当シートが無い場合止まってしまうので再開時には変換済みのファイルパスは正確に削除してから再開しないと、止まるたびに最初から変換作業することになって作業効率悪し。（実際には進まない）

●改善点：D列以降に第2、第3のシート名を入力し、該当ない場合は無視する

以上2点、言いたい放題ですが上記しましたようにすでに200程度は「シート名指定」のVBAで処理できましたのでどちらか1つでも改善していただければ非常にありがたく。

ここまで完璧にできたので「何とか出来るなら」のお願いです。

回答No.5

HohoPapa · ベストアンサー

以下のように理解しましたがいかがでしょうか。

>https://okwave.jp/qa/q10024075.html　の
>2022/06/28 12:48　回答No.5
これを改修することを期待しているのではなく

>https://okwave.jp/qa/q10028861.html　の
>2022/07/12 22:18　回答No.3
これを改修してほしい。

改修事項は以下。

①
>>PDFの保存先は元のフォルダ中に新らしく
>>「PDF変換」というフォルダを作成してそこに保存される。
という仕様はやめる。つまり、
PDFファイルの出力先は、
PDF作成元ファイルの所属フォルダーの下階層に動的にフォルダーを作成するのではなく
常に固定したフォルダーにする。
そのフォルダーは、
VBAのコード内に指定する。
それとも、D1セルにセットしますか？

②
>空白シート（A1:AZ100）に文字、数字が無いシート
この条件を満たすシートは
PDFの作成対象外にする。

③
PDF作成元ファイルのフルパスは、Ａ列にセットする。

④
PDF作成元シートは、Ｂ列にセットする。

⑤
>Ｃ列（セル指定）の無いケース
利用者は、C列に、セルのアドレスではなく
ファイル名に埋める文字列をセットする。
VBAは、この文字列が空欄だったら、PDFの作成対象外にする。

お礼

何度もお手数をお掛けします。

別スレッドを立てますので宜しくお願い致します。

補足

本当にすみません！
金曜日に別スレッドを立てたのですが、その後図と質問文の内容の齟齬に気付き誤解を招いては一大事と一旦質問を削除し、改めて質問したら、図の添付を忘れて再度取り消し。
再々質問したつもりで忘れてしまって帰宅。

今朝早々に再々質問しようとしたらご回答がありました。
前回のご回答（指示）に従い、やりたいことを再度整理して再々質問として別スレッドを立てますので何卒宜しくお願いします。

やりたいことを行き当たりばったりでお願いし、混乱してしまいお手数をお掛けしますが、ほぼ完成形なので出来ればお願いしたいと思います。

回答No.4

HohoPapa

https://okwave.jp/qa/q10024075.html　の
2022/06/28 12:48　回答No.5
ここで紹介したコードをどのように修正したいのか
私が見失っています。

そもそも、２つの課題が１つのスレッドになっていることで混乱しています。
改めて、
https://okwave.jp/qa/q10024075.html　の
2022/06/28 12:48　回答No.5
をどうしたいのか、スレッドを立ててください。

お礼

混乱してしまい本当に申し訳なく。
別のスレッドを立てましたので何卒宜しくお願いします。

補足

当方も混乱してしまっていて大変申し訳なく。
最初に想定していなかった問題が発覚して安易に追加要求してしまいました。

何故2つのコードが必要かを考えてみたら、
１．エクセルBookの中に変換不要のシートと無意識に存在する空白シートが入っている。
２．シート名で絞りむと「申請書」や「成績表」のように同じファイル名になってしまうBookが有る。

下記の手順を考えました。
１．デスクトップに「変換元エクセル」「ＰＤＦ変換後」の2つのフォルダを作成しておく。
２．変換したいエクセルファイルを「変換元エクセル」フォルダにコピペ。
３．変換用エクセルのシートのＡ列に対象のファイルのフルパス、Ｂ列に目的のシート名、Ｃ列にファイル名に付加したいセル内容を入力してＶＢＡ実行。

この時に
１．Ｃ列（セル指定）の無いケース
２．空白シート（A1:AZ100）に文字、数字が無いシート
の2つのケースを無視する。

これで１つのVBAで種々のシート構成のBookのPDF化が達成できるのですが。

回答No.3

HohoPapa

何度もごめんなさい。
もう１回、差し替えます。(-.-)

Option Explicit

Dim ShCltl As Worksheet
Dim SeqNum As Long

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

Sub Sample()

　Const SRow = 2 'ブック一覧の開始行番号
　Dim RowNum As Long

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

End Sub

'//---------- PDFに書き出すサブルーチン
Sub ExportPDF3(RowNum As Long)

　Dim tgBook As Workbook
　Dim tgSheet As Worksheet
　Dim PdfDir As String
　Dim i As Long
　Dim PutName As String

　Set tgBook = Workbooks.Open(FileName:=ShCltl.Cells(RowNum, 1).Value)
　'指定シートが無ければPDF出力元ファイルを閉じて抜ける
　If isInSheet(tgBook, ShCltl.Cells(RowNum, 2).Value) = False Then
　　 tgBook.Close SaveChanges:=False
　　 Exit Sub
　End If
　Set tgSheet = tgBook.Sheets(ShCltl.Cells(RowNum, 2).Value)
　'シートがバージンならPDF出力元ファイルを閉じて抜ける
　If IsVirgin(tgSheet, ChkRange) = True Then
　　 tgBook.Close SaveChanges:=False
　　 Exit Sub
　End If

　PdfDir = GetPath(ShCltl.Cells(RowNum, 1).Value) & "\PDF変換"

　'出力先フォルダーのチェック、なかったら作成する
　If IsExistDirA(PdfDir) = False Then
　MkDir PdfDir
　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

　'PDF出力元ファイルを閉じる
　tgBook.Close SaveChanges:=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

'//==============シートが実在するか？を判定する関数
Function isInSheet(MyBook As Workbook, ShName As String) As Boolean
　Dim i As Long
　isInSheet = False
　For i = 1 To MyBook.Sheets.Count
　　 If MyBook.Sheets(i).Name = ShName Then
　　　　isInSheet = True
　　　　Exit For
　　 End If
　Next i
End Function

お礼

なんども訂正や追加で申し訳ありません。

先ほどの、昨夜の思いつきの「補足」は今回対応いただいています。
慌てて混乱してしまいました。

コード２でもセル名の複数指定ではなく、空白シートの無視でも対策になると思うのですが。
どちらでも良いので出来る範囲で・・・

これ以上はないと思いますが、もし更なる追記があれば古い回答の枠に投稿します。

補足

早々のご回答いつも申し訳なく。
＞何度もごめんなさい。
＞もう１回、差し替えます。(-.-)
などと言われると何度もなんども追加要求している当方としては心苦しく身の置き処に困ってしまいます。
ご回答の確認は明日中には実施します。

処で１．に関して昨夜思ったのですが、想定外（不明）シートはデフォルトで付いているシートに限定出来ることに気付きました。
シートが複数あることが分かっていればシート名を指定して実行することが前提ですので。
実際に同じファイルパスを複数行にコピペして、シート名を変えて検証もしています。

つまり、想定外のシート名は「Sheet１」「Sheet２」「Sheet3」のいづれか1つまたは2つのケースに限定されます。

もしこの条件で出来るなら気長にお待ちしますので出来ればお願いします。
ダメでも、ファイル数を30個程度に分割して処理することでも十分に効果的ですので無理は不要でお願いします。

今後毎日 継続的にこの作業が有るわけではなく、過去の遺産のPDF化なので、HohoPapaさんのコスパ？の許す範囲でのご回答で結構です。

当方の労力をHohoPapaさんに押し付けている自覚は十分にありますので。

過去の記録（エクセル）を参照して、無意識に上書き保存するケースが結構あり、ファイルの作成日と事実が齟齬していて、記録の証拠能力に疑問（指摘）があり、その対策の１つです。

回答No.2

HohoPapa

一部間違いがあり、差し替えます。　(-.-)

Option Explicit

Dim ShCltl As Worksheet
Dim SeqNum As Long

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

Sub Sample()

　Const SRow = 2 'ブック一覧の開始行番号
　Dim RowNum As Long

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

End Sub

'//---------- PDFに書き出すサブルーチン
Sub ExportPDF3(RowNum As Long)

　Dim tgBook As Workbook
　Dim tgSheet As Worksheet
　Dim PdfDir As String
　Dim i As Long
　Dim PutName As String

　Set tgBook = Workbooks.Open(FileName:=ShCltl.Cells(RowNum, 1).Value)
　'指定シートが無ければ抜ける
　If isInSheet(tgBook, ShCltl.Cells(RowNum, 2).Value) = False Then
　　'PDF出力元ファイルを閉じる
　　tgBook.Close SaveChanges:=False
　　Exit Sub
　End If
　Set tgSheet = tgBook.Sheets(ShCltl.Cells(RowNum, 2).Value)
　PdfDir = GetPath(ShCltl.Cells(RowNum, 1).Value) & "\PDF変換"

　'出力先フォルダーのチェック、なかったら作成する
　If IsExistDirA(PdfDir) = False Then
　MkDir PdfDir
　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出力
　If IsVirgin(tgSheet, ChkRange) = True Then Exit Sub
　tgSheet.ExportAsFixedFormat Type:=xlTypePDF, _
　　FileName:=PutName, _
　　Quality:=xlQualityStandard, _
　　IncludeDocProperties:=True, _
　　IgnorePrintAreas:=False, _
　　OpenAfterPublish:=False

　'PDF出力元ファイルを閉じる
　tgBook.Close SaveChanges:=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

'//==============シートが実在するか？を判定する関数
Function isInSheet(MyBook As Workbook, ShName As String) As Boolean
　Dim i As Long
　isInSheet = False
　For i = 1 To MyBook.Sheets.Count
　　If MyBook.Sheets(i).Name = ShName Then
　　　isInSheet = True
　　　Exit For
　　End If
　Next i
End Function

回答No.1

HohoPapa

>●改善点：D列以降に第2、第3のシート名を入力し、該当ない場合は無視する
こちらは、手直し、手戻りが大きいので、棚上げします。
どうしても！。ということであれば、コメントし、
気長に待つか、他の識者の方の応答に期待してください。

>●改善点：空白のシートは無視できませんか？
こちらは、手戻りがないので対応してみました。
なお、空白のシートは、言葉にすると一言ですが
罫線だけがあるとか、色を染めたセルだけがあるとか、
考え出すときりがありません。
そこで、指定したセル範囲に値、計算式がない場合を空白のシートとしました。

また、指定したシート名のシートがない場合は、
エラーとせず、スルーするようにしました。

以下が、そのコードです。

Option Explicit

Dim ShCltl As Worksheet
Dim SeqNum As Long

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

Sub Sample()

　Const SRow = 2 'ブック一覧の開始行番号
　Dim RowNum As Long

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

End Sub

'//---------- PDFに書き出すサブルーチン
Sub ExportPDF3(RowNum As Long)

　Dim tgBook As Workbook
　Dim tgSheet As Worksheet
　Dim PdfDir As String
　Dim i As Long
　Dim PutName As String

　Set tgBook = Workbooks.Open(FileName:=ShCltl.Cells(RowNum, 1).Value)
　If isInSheet(tgBook, ShCltl.Cells(RowNum, 2).Value) = False Then
　　Exit Sub
　End If
　Set tgSheet = tgBook.Sheets(ShCltl.Cells(RowNum, 2).Value)
　PdfDir = GetPath(ShCltl.Cells(RowNum, 1).Value) & "\PDF変換"

　'出力先フォルダーのチェック、なかったら作成する
　If IsExistDirA(PdfDir) = False Then
　MkDir PdfDir
　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出力
　If IsVirgin(tgSheet, ChkRange) = True Then Exit Sub
　tgSheet.ExportAsFixedFormat Type:=xlTypePDF, _
　　FileName:=PutName, _
　　Quality:=xlQualityStandard, _
　　IncludeDocProperties:=True, _
　　IgnorePrintAreas:=False, _
　　OpenAfterPublish:=False

　'PDF出力元ファイルを閉じる
　tgBook.Close SaveChanges:=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

'//==============シートが実在するか？を判定する関数
Function isInSheet(MyBook As Workbook, ShName As String) As Boolean
　Dim i As Long
　isInSheet = False
　For i = 1 To MyBook.Sheets.Count
　　If MyBook.Sheets(i).Name = ShName Then
　　　isInSheet = True
　　　Exit For
　　End If
　Next i
End Function

なお、毎度のことですが、ごく簡単な動作テストしかしていませんので
しっかり確認してください。

また、
>結局2つのコードをご回答いただいたのですが
このうち、対応したのは一方です。

他方も、
>●改善点：空白のシートは無視できませんか？
これを組み込むことを期待していますか？