VBAでフォルダ内のPDFファイルの一覧表(再）

質問

この質問は下記のご回答いただいたVBAに関する追加の質問ですのでご了承下さい。
https://okwave.jp/qa/q10124583.html

ご回答で出来た一覧表を紹介して、先ほど一覧表を開けて見たら件数が激減。
原因は、閲覧者が試しに検索ボタンをクリックして検索期間が変わってました。（当方は2000/1/1以降の結果を保存し、ファイルのパスを回覧しました）
これは今後も想定される事態なので解決策として下記のどちらか簡単な方での対応をお願いしたいのです。
最後の最後までおんぶに抱っこでいつもながら誠に申し訳なく・・・

１．ＶＢＡの実行ボタンをクリックするとパスワードの要求が出る。
パスはシート上の指定のセルに入力。
２．出力シートを別のエクセルのフルパスのファイルに変更する。
検索開始時点では出力ファイルは開いていない前提。

現在はSheet1に検索条件とＶＢＡの実行ボタンを配置して、クリックするとSheet2に結果が出力されるようになっています。

一応NETで調べてみましたが当方の実力（単に追加）ではうまくいかず。

回答No.4

HohoPapa · ベストアンサー

>シート毎に部署ごとのシートを作成してフルパスと出力シート名を指定してすれば良いと考えた
そのようにしてみました。

>パスの設定は外して頂きたく。
パスワードの入力を求めないようにしました。

>シートモジュールにコピペしてもエラーとなってしまいました
シートごとにシートモジュールに配置すると
同じコードが複数個所に書き込まれることとなり、好ましくありません。

通常は、標準モジュールに配置した状態で
複数シートに対応するコードにします。
都合、後記コードは標準モジュールに配置してください。

おそらく、シートにボタンを配置し、
そのボタンを押すことでマクロが動くようにしているものと思います。

ボタンがフォームコントロールなら、添付画像のようにマクロを紐づけてください。
ボタンがActiveXコントロールなら
それぞれのシートモジュールに

Private Sub CommandButton1_Click()
　sample
End Sub

といったコードを配置してください。

Option Explicit

'以下を参照設定
'Microsoft Scripting Runtime

Dim BaseDir As String　'親フォルダー名
Dim BorderDay As Date　'基準日
Dim RowCount As Long　 '行カウンター
Dim PutBook As Workbook　'出力先ブック
Dim PutSheet As Worksheet　'出力先シート

Sub sample()

　Dim GetPW As String　　'マクロ起動用パスワード
　Dim rc As Integer　　　'MSGBoxの戻り値

　With ActiveSheet

　　If InStr(.Cells(3, 1).Value, "\") = 0 Then
　　　Set PutBook = Workbooks.Open(ThisWorkbook.path & "\" & .Cells(3, 1).Value)
　　Else
　　　Set PutBook = Workbooks.Open(.Cells(3, 1).Value)
　　End If

　　Set PutSheet = PutBook.Sheets(.Cells(4, 1).Value)

　　BaseDir = .Cells(1, 1).Value
　　BorderDay = .Cells(2, 1).Value

　End With

　' 出力先シートをクリアー
　With PutSheet
　　Range(.Rows(6), .Rows(Rows.Count)).ClearContents
　End With

　RowCount = 5　　'6行目から出力
　getFilesRecursive (BaseDir)

　rc = MsgBox("リストアップが終了したので" & vbCrLf & _
　　PutBook.path & "\" & PutBook.Name & vbCrLf & _
　　"を保存して閉じます。", vbOKCancel)
　If rc = vbOK Then
　　PutBook.Close SaveChanges:=True
　Else
　　PutBook.Close SaveChanges:=False
　End If

End Sub

'フォルダー、ファイルを総当たり
Sub getFilesRecursive(path As String)

　Dim FSO As FileSystemObject: Set FSO = New FileSystemObject
　Dim objFolder As folder
　Dim objFile As file

　'フォルダーを個々に取得
　For Each objFolder In FSO.GetFolder(path).SubFolders
　　getFilesRecursive objFolder.path
　Next

　'ファイルを個々に取得
　For Each objFile In FSO.GetFolder(path).Files
　　If UCase(FSO.GetExtensionName(objFile.path)) = "PDF" Then
　　　execute objFile
　　End If
　Next

End Sub

'取得したファイルをリストアップ
Sub execute(f As file)

　Dim MidDir As String
　Dim FName As String

　'作成日時が指定日より過去のファイルは無視する
　If f.DateCreated < BorderDay Then Exit Sub

　RowCount = RowCount + 1

　With PutSheet　　　'出力先シート

　　Range(.Cells(RowCount, 1), .Cells(RowCount, 3)).NumberFormatLocal = "@"
　　.Cells(RowCount, 4).NumberFormatLocal = "yyyy/m/d h:mm;@"

　　.Cells(RowCount, 1).Value = BaseDir & "\"
　　MidDir = Mid(f.path, Len(BaseDir) + 2, InStrRev(f.path, "\") - Len(BaseDir) - 1)
　　.Cells(RowCount, 2).Value = MidDir
　　FName = Mid(f.path, InStrRev(f.path, "\") + 1, 256)
　　.Cells(RowCount, 3).Value = FName

　　.Cells(RowCount, 4).Value = f.DateCreated

　　.Hyperlinks.Add Anchor:=.Cells(RowCount, 3), _
　　　　Address:=f.path, TextToDisplay:=FName

　End With

End Sub

お礼

今回も我が儘放題、何度もお手数をお掛けしてしまいました。
連休中にご回答いただいて検証できずに気になっていて、これが一発で動かなかったら・・・と思うと、
Bookを必要数作ればそれでもよかったのでは、と若干の後悔を感じながらの 今朝の一発完動でした。
自分で何もしていないのに強い達成感を感じています。

今回もお手数をお掛けしましたが 本当にありがとうございました。

補足

おはようございます。
お礼が遅くなり本当に申し訳ありません。
連休中は3人の子供たちの孫のところへ行ったり来たりで頼んでおいて申し訳ありませんでした。

さて、朝一の一で何度もご回答を読んで、デモBookをデスクトップに配置して、検索条件シートにNETで調べてフォームコントールでボタンを作成し、イザと思ったらセル番地の変更を忘れていてエラー。

気を取り直して・・・
お見事！一発回答！！！！

回答No.3

HohoPapa

>下記のどちらか簡単な方での対応
この記述を見落とし、双方とも組み込んでいます。
どちらか一方にしたい場合は選択してください。直してポストします。

お礼

驚くべきことに、まさかの1発完全回答でした！
当方のレベルに合わせた解説付きのおかげです。
私の場合NETで検索したVBAさえ一発で動くことはないのでこれに一番ビックリです。

パスの設定はあって困ることは無いのでこれ以上のお手数は全く不要です。

後しばらく 補足枠を残して検証してみてから締め切らせて頂きますので少々お待ちください。

補足

HohoPapaさん
今日は連休なのでこれをやりに出社して朝から一日これをいじっているのですが、大幅な改定のお願いです。

このVBAのコードをシートモジュールにしていただきたいのです。
試しにシートモジュールにコピペしてみたのですが「コンパイルエラー」でやはりだめでした。

背景は私の工場では対象情報が部署に寄らずに工場の専用（親）フォルダに集約されているのですが、別工場では生産部署ごとに（親）フォルダを作成しています。

この場合「検索用Book」のシート毎に部署ごとのシートを作成してフルパスと出力シート名を指定してすれば良いと考えたのですが、ご回答のコードを単にシートモジュールにコピペしてもエラーとなってしまいました。

間に合うなら何卒最後？のお願いです。

あまりにしつこいので無視でも全くOKです。
この追加要求を慌てて書きながら、部署ごとに検索Bookを作れば良いだけと気付きましたが、1つのBookの方が完成度（スマート）が高い。
私が言うのもなんですが・・・

先ずは投稿します。

回答No.2

HohoPapa

こんな感じでしょうか。

なお、
>検索開始時点では出力ファイルは開いていない前提。
予め開いておいても機能します。

Option Explicit

'以下を参照設定
'Microsoft Scripting Runtime

Dim BaseDir As String　'親フォルダー名
Dim BorderDay As Date　'基準日
Dim RowCount As Long　 '行カウンター
Dim PutBook As Workbook　'出力先ブック
Dim PutSheet As Worksheet　'出力先シート

Sub sample()

　Dim GetPW As String　　'マクロ起動用パスワード
　Dim rc As Integer　　　'MSGBoxの戻り値

　With ThisWorkbook.Sheets("Sheet2")

　　GetPW = InputBox("マクロ起動用のパスワードを入力してください")
　　If GetPW <> .Cells(5, 1).Value Then
　　　MsgBox "パスワードが違います"
　　　Exit Sub
　　End If

　　If InStr(.Cells(3, 1).Value, "\") = 0 Then
　　　Set PutBook = Workbooks.Open(ThisWorkbook.path & "\" & .Cells(3, 1).Value)
　　Else
　　　Set PutBook = Workbooks.Open(.Cells(3, 1).Value)
　　End If

　　Set PutSheet = PutBook.Sheets(.Cells(4, 1).Value)

　　BaseDir = .Cells(1, 1).Value
　　BorderDay = .Cells(2, 1).Value

　End With

　' 出力先シートをクリアー
　With PutSheet
　　Range(.Rows(6), .Rows(Rows.Count)).ClearContents
　End With

　RowCount = 5　　'6行目から出力
　getFilesRecursive (BaseDir)

　rc = MsgBox("リストアップが終了したので" & vbCrLf & _
　　PutBook.path & "\" & PutBook.Name & vbCrLf & _
　　"を保存して閉じます。", vbOKCancel)
　If rc = vbOK Then
　　PutBook.Close SaveChanges:=True
　Else
　　PutBook.Close SaveChanges:=False
　End If

End Sub

'フォルダー、ファイルを総当たり
Sub getFilesRecursive(path As String)

　Dim FSO As FileSystemObject: Set FSO = New FileSystemObject
　Dim objFolder As folder
　Dim objFile As file

　'フォルダーを個々に取得
　For Each objFolder In FSO.GetFolder(path).SubFolders
　　getFilesRecursive objFolder.path
　Next

　'ファイルを個々に取得
　For Each objFile In FSO.GetFolder(path).Files
　　If UCase(FSO.GetExtensionName(objFile.path)) = "PDF" Then
　　　execute objFile
　　End If
　Next

End Sub

'取得したファイルをリストアップ
Sub execute(f As file)

　Dim MidDir As String
　Dim FName As String

　'作成日時が指定日より過去のファイルは無視する
　If f.DateCreated < BorderDay Then Exit Sub

　RowCount = RowCount + 1

　With PutSheet　　　'出力先シート

　　Range(.Cells(RowCount, 1), .Cells(RowCount, 3)).NumberFormatLocal = "@"
　　.Cells(RowCount, 4).NumberFormatLocal = "yyyy/m/d h:mm;@"

　　.Cells(RowCount, 1).Value = BaseDir & "\"
　　MidDir = Mid(f.path, Len(BaseDir) + 2, InStrRev(f.path, "\") - Len(BaseDir) - 1)
　　.Cells(RowCount, 2).Value = MidDir
　　FName = Mid(f.path, InStrRev(f.path, "\") + 1, 256)
　　.Cells(RowCount, 3).Value = FName

　　.Cells(RowCount, 4).Value = f.DateCreated

　　.Hyperlinks.Add Anchor:=.Cells(RowCount, 3), _
　　　　Address:=f.path, TextToDisplay:=FName

　End With

End Sub

補足

出力用Bookを所定の場所に作成してシート名やら見た目を整えて何も問題なく期待通り（以上）の出来栄えを確認しました。

だた1つ気になってきたのは、パスワードは有っても良いと思ったのですが、検索条件を入力するシートにパスワードを入れて実行すると、入れてあるPWを見ながらＰＷ
を入力する作業は矛盾していることに気付きました。

折角なので、大変申し訳ないのですがパスの設定は外して頂きたく。

このままの使用で何も問題は無いのですが使う人が違和感を持つと思うので 私が言うのもなんですがより完成度を上げておきたく。

贅沢な要求ですがこれが最後のお願いです（最後が何度も有りますが）

下記の辺りを適当に削除してみましたがダメでしたので安直にお願いしてしまいます。

GetPW = InputBox("マクロ起動用のパスワードを入力してください")
If GetPW <> .Cells(8, 3).Value Then
MsgBox "パスワードが違います"
Exit Sub
End If

回答No.1

aokii

フォルダ内のPDFファイルの一覧表を作るのでしたら、Neo FileInfoList(無料)というソフトを使ってみて下さい。

お礼

ご回答ありがとうございました。

但し、この質問は冒頭に記しましたように前回の回答の続き（追加要求）なので単にリストの抽出ではないのでごめんなさい。

また、せっかく教えて頂いたんぼで試してみようとしましたが会社のセキュリティに引っ掛かりDL来ませんでした。
ご回答はプライベートで使用する可能性がありますので感謝です！！！！