複数のフォルダに保存されているファイルの検索

質問

いつもお世話になっております。
ややこしい要求で、うまく説明できるか不安要素が有るのですが。

多くの製品に関する情報が品種別フォルダに格納されています。
「製品」というフォルダの中に「アルファベット（A~Z）」「50音（あ～わ）」「数字（０－９）」のフォルダに分かれています。
各製品のフォルダの中は色んな情報がフォルダに分類されて保存されています。

品名別（例えば「A」)フォルダの中に「ABC１２３」という製品名のフォルダがあり、その中に「成績表」というフォルダがあります。
その中には、LOTごとの品質成績表がワード、もしくはPDFで保存されているのですが、全製品のワードファイルとPDFファイルの作成日を一覧にする方法はないでしょうか？

保存されている成績表の枚数が製品によって大きく違うので直近の5枚とか、過去２年間のファイルの作成日のどちらかが分かれば非常に助かるのですが。

回答No.8

HohoPapa · ベストアンサー

乗りかかった船なので、
>フォルダの文言が「成績表」「成績書」
>「試験成績表」等有ることも分かりました。
に対応し、
更にアルファベットの大文字小文字の区別もしないようにしてみました。

Option Explicit

Const tgDir = "\\Srv01\・・・\部\課\チーム\☆成績書"

'//--------------------
Sub Sample()

　Dim startCell As Range
　Dim maxRow As Long
　Dim maxCol As Long

　Set startCell = Cells(2, 3)　　'このセルから出力し始める
　startCell.Select

　'出力先シートをクリア
　maxRow = startCell.SpecialCells(xlLastCell).Row
　maxCol = startCell.SpecialCells(xlLastCell).Column
　Range(startCell, Cells(maxRow, maxCol)).ClearContents

　Call getFileList(tgDir, "1.成績表")
　Call getFileList(tgDir, "1.成績書")
　Call getFileList(tgDir, "1.試験成績表")

End Sub

'//--------------------
Sub getFileList(searchPath As String, PicDir As String)

　Dim FSO As New FileSystemObject
　Dim objFiles As File
　Dim objFolders As Folder
　Dim separateNum As Long

　'サブフォルダ取得
　For Each objFolders In FSO.GetFolder(searchPath).SubFolders
　　Call getFileList(objFolders.Path, PicDir)
　Next

　'ファイル名の取得
　For Each objFiles In FSO.GetFolder(searchPath).Files
　　 separateNum = InStrRev(objFiles.Path, "\")
　　 If StrConv(StrConv(Right(Left(objFiles.Path, separateNum - 1), _
　　　　 Len(PicDir)), vbWide), vbUpperCase) = _
　　　　 StrConv(StrConv(PicDir, vbWide), vbUpperCase) Then
　　　'セルにパスとファイル名を書き込む
　　　ActiveCell.Value = Left(objFiles.Path, separateNum - 1)
　　　ActiveCell.Offset(0, 1).Value = _
　　　　　Right(objFiles.Path, Len(objFiles.Path) - separateNum)
　　　ActiveCell.Offset(0, 2).Value = FileDateTime(objFiles)
　　　ActiveCell.Offset(0, 3).Value = Format((FileLen(objFiles) / 1024), "#.0")
　　　ActiveCell.Offset(1, 0).Select
　　End If
　Next

End Sub

お礼

ひえ～　まさかの改良版！！
昨日までの結果を昨夜確認して、朝一でBA選定して閉め切ろうと思って今開けてみたら改良版が入っていました。

結局何度も複数のコードを作ってもらうことになってしまい申し訳ありませんでした。
せめて最初から「最後の条件まで」を提示出来ればよかったのですが、無知故いつもの通り追加の質問になってしまい申し訳ありませんでした。

このコードは未確認ですが、間違いないと自信が有りますので？？？一旦締め切らせていただきます。
万が一の時は別の質問として投稿しますのその節にもよろしく願いします。

回答No.7

HohoPapa

'ファイル名の取得
　For Each objFiles In FSO.GetFolder(searchPath).Files
　　separateNum = InStrRev(objFiles.Path, "\")
　　If Right(Left(objFiles.Path, separateNum - 1), Len(PicDir)) = PicDir Then
　　　'セルにパスとファイル名を書き込む
　　　ActiveCell.Value = Left(objFiles.Path, separateNum - 1)

↑を↓に書き換えてください。

'ファイル名の取得
　For Each objFiles In FSO.GetFolder(searchPath).Files
　　 separateNum = InStrRev(objFiles.Path, "\")
　　 if StrConv(Right(Left(objFiles.Path, separateNum - 1), Len(PicDir)), vbWide) = _
　　　　 StrConv(PicDir, vbWide) then
　　　'セルにパスとファイル名を書き込む
　　　ActiveCell.Value = Left(objFiles.Path, separateNum - 1)

そうすることで、
半角、全角の区別なく指定のフォルダーを対象にできます。

お礼

いつもながらの当方のレベルに合わせたご回答に感謝、感激、感服致します。

今回はあまりにも当方のレベルを超えているため別の問題も認識していますが、上記の方法では膨大な工数がかかっており、そもDOS処理も完全に理解しているわけではないので問題は同じ。

この方法は何せエクセルなので当方でもマニュアル化しやすいので、後の人が機械的に処理できるように整備して、予備ファイル（動作確認ファイル）も残しておきます。

本当にありがとうございました。

補足

夜に動くことを確認し、朝一で実フォルダで試しました。
抽出数が大きく増えたので間違いないと思います。
但し、昨日のデータ検証で、フォルダの文言が「成績表」「成績書」「試験成績表」等有ることも分かりました。

これまでは「A」「B」「あ」「い」・・・ファルダを機械的に処理していたので気付きませんでした。
（各フォルダをDOS画面で処理して、50音、アルファベット、数字の各フォルダのファイル情報をTEXTで取得し、その約80個のエクセルファイルをDOS画面で1枚にまとめる）

今回のご回答で全角、半角が区別なく抽出できるので、各文言ごとにファイルを作っておけば数枚（3-5？枚程度）のエクセルファイルにできますのでこれで十分でとりあえずこれで作業開始したいと考えています。

もし、本質的な問題が発生したときには見放さずに何卒よろしくお願い致します。

回答No.6

HohoPapa

>3つ下の階層にある「1.成績表」のフォルダ
『3つ下』という条件ではちょっと面倒なので
指定のフォルダー："\\Srv01\・・・\部\課\チーム\☆成績書"
この下階層から"1.成績表"のフォルダーを見つけ
リストアップするようにしてみました。

Option Explicit

Const tgDir = "\\Srv01\・・・\部\課\チーム\☆成績書"
Const PicDir = "1.成績表"

Sub Sample()
　Call setFileList(tgDir)
End Sub

'//--------------------
Sub setFileList(searchPath)
　Dim startCell As Range
　Dim maxRow As Long
　Dim maxCol As Long

　Set startCell = Cells(5, 2) 'このセルから出力し始める
　startCell.Select

　 'シートをいったんクリア
　maxRow = startCell.SpecialCells(xlLastCell).Row
　maxCol = startCell.SpecialCells(xlLastCell).Column
　Range(startCell, Cells(maxRow, maxCol)).ClearContents

　Call getFileList(searchPath)
　startCell.Select
End Sub

'//--------------------
Sub getFileList(searchPath)

　Dim FSO As New FileSystemObject
　Dim objFiles As File
　Dim objFolders As Folder
　Dim separateNum As Long

　'サブフォルダ取得
　For Each objFolders In FSO.GetFolder(searchPath).SubFolders
　　Call getFileList(objFolders.Path)
　Next

'ファイル名の取得
　For Each objFiles In FSO.GetFolder(searchPath).Files
　　separateNum = InStrRev(objFiles.Path, "\")
　　If Right(Left(objFiles.Path, separateNum - 1), Len(PicDir)) = PicDir Then
　　　'セルにパスとファイル名を書き込む
　　　ActiveCell.Value = Left(objFiles.Path, separateNum - 1)
　　　ActiveCell.Offset(0, 1).Value = Right(objFiles.Path, Len(objFiles.Path) - separateNum)
　　　ActiveCell.Offset(0, 2).Value = FileDateTime(objFiles)
　　　ActiveCell.Offset(0, 3).Value = Format((FileLen(objFiles) / 1024), "#.0")
　　　ActiveCell.Offset(1, 0).Select
　　End If
　Next

End Sub

お礼

一旦作業を中断して、早々にお礼とBSで閉め切ろうとしてかなりデータ数が違っているので少し検証してみたら、「1.成績表」の「１」と「．」が半角、全角が混在していることが判明しました。

当方が着任後は英数カタカナ()は半角と決めたのですが昔のフォルダ＋ウッカリも有るようです。（複数の人が作業するのでこの程度のミスは致し方なし）

お礼を書きかけて追加の質問になってしまうのですが、
＞Const PicDir = "1.成績表"
これを複数個指定することは出来ないでしょうか？
他にも極少数「1.試験成績表」も有りました。

大きく変わるようなら、前回のリストをフィルタしますのであまりお手数をかけていただかなくて結構です。

どなたかが言ってましたが、「無料の範囲ではない」こと、承知で申し訳なく・・・・

補足

すごいです！！
朝一で確認してみたら、一発で目的の結果が得られました。

最初は黒画面になってしまってヒヤリとしましたが待つこと数十秒でいきなり結果が表示されました。

昨日の結果とかなり抽出数が違っているのですが、これはフォルダ構成のためだと思いますので、これから詳細を検証しフォルダ構成の改善を試みてみます。

「ノイズあり/漏れなし」、と「ノイズ無し/漏れあり」のどちらでも出来るので一旦締め切らせてもらいます。（再度の節はよろしくお願いします）

回答No.5

HohoPapa

http://blog.jmiri.net/?p=1763
の冒頭で説明している
※メニュー[ツール]→[参照設定]で、「Microsoft Scripting Runtime」にチェックが入っていない場合はチェックしておきましょう。
が必要です。

お礼

申し訳ありません。
今早速結果一覧表で作業を開始したところ、最終目的の「1.成績表」フォルの階層は色んな深さが有ること気付きました。
よって質問のファルダの下3つ目ではなく、中抜きのパスでないと駄目なことが分かりました。

いつもながら質問前の状況把握が甘くすみません。

補足

毎度（複数回）お世話になっております。

先ずは結果報告。
動きました。感動！！！！

但し（がまたまた付き申し訳ありません）最初はデスクトップにあるフォルダで試して感動したのですが、目的のパスで試したら9分間かかりました。
この時間は大した問題ではないのですが、結果が30000行になってしまってこの中から必要なファイルを抽出するのにまたまた「ご相談」になりかねない状況となりました。

ここまで書いて表にフィルタをかけること気付いて試してみたら必要なファイルは1000程度でした。（処理は20秒程度で終わる計算）

そこで厚かましくも追加の質問（要求）ですが、質問に例示のパスの下に製品ごとの例えば「A」のフォルダがあり、その下に「ABC123」という製品フォルダがあり、その下に必ず「品質」、その下に必ず「1.成績表」というフォルダがあります。
つまり質問に例示のフォルダの3つ下の階層にある「1.成績表」のフォルダを指定して（中抜きのパス）での対応は出来ないでしょうか？

"\\Srv01\・・・\部\課\チーム\☆成績書"・・・・”1.成績表”

あまり複雑（当方にはハードルが高い）ようなら上記のご回答で十分ですのでお手数なら本当に結構です。
（1つ1つのフォルダ別に処理していたことを思うとご回答で十分です）

回答No.4

HohoPapa

以下のコードを標準モジュールに貼り付け
Sub Sample()
を実行することで期待の動きになりませんでしょうか？
エラーならエラーメッセージ詳細を説明してみてください。

Option Explicit

Sub Sample()
Call setFileList("\\Srv01\・・・\部\課\チーム\☆成績書")
End Sub
'//--------------------
Sub setFileList(searchPath)
　　Dim startCell As Range
　　Dim maxRow As Long
　　Dim maxCol As Long

　　Set startCell = Cells(5, 2) 'このセルから出力し始める
　　startCell.Select

　　'シートをいったんクリア
　　maxRow = startCell.SpecialCells(xlLastCell).Row
　　maxCol = startCell.SpecialCells(xlLastCell).Column
　　Range(startCell, Cells(maxRow, maxCol)).ClearContents

　　Call getFileList(searchPath)
　　startCell.Select
End Sub

'//--------------------
Sub getFileList(searchPath)

　　Dim FSO As New FileSystemObject
　　Dim objFiles As File
　　Dim objFolders As Folder
　　Dim separateNum As Long

　　'サブフォルダ取得
　　For Each objFolders In FSO.GetFolder(searchPath).SubFolders
　　　　Call getFileList(objFolders.Path)
　　Next

　　'ファイル名の取得
　　For Each objFiles In FSO.GetFolder(searchPath).Files
　　　　separateNum = InStrRev(objFiles.Path, "\")
　　　　'セルにパスとファイル名を書き込む
　　　　ActiveCell.Value = Left(objFiles.Path, separateNum - 1)
　　　　ActiveCell.Offset(0, 1).Value = Right(objFiles.Path, Len(objFiles.Path) - separateNum)
　　　　ActiveCell.Offset(0, 2).Value = FileDateTime(objFiles)
　　　　ActiveCell.Offset(0, 3).Value = Format((FileLen(objFiles) / 1024), "#.0")
　　　　ActiveCell.Offset(1, 0).Select
　　Next

End Sub

補足

お世話になります。
昨夜自宅のPCのローカルファイルのホルダで、今、会社のNET上の実際のホルダで試してみました。

同じ結果で「コンパイルエラー、ユーザ定義型は定義されていません」とメッセージが出ます。

下記の1行目が黄色のハイライトで、2行目は選択された状態（青背景）になります。

Sub getFileList(searchPath)

Dim FSO As New FileSystemObject

お手数をおかけしますが何とかよろしくお願いします。

回答No.3

imogasi

（１）VBAとFSOという付属ソフト・機能を使って、やっとやれるかな、という課題です。
（２）会社の中に、VBAができる人はいませんか。
（３）　無料でやりたいとせず、会社の、出入りのソフト業者に、頼むことはできないかな。
（４）出来合いのフリーソフトがあるか探す手もあるが、探すのがむつかしいでしょう。この機能だけの市販ソフトは、売り出しても、買う人はほとんどなく、売り出すはずがない。ファイル管理ソフトという部類のものがあれば、その中に
この機能があるかも。
ーーー
本件は、処理対象は、フォルダが複数であるようだから、フォルダ名をエクセルシートの例えばA列に並べて、それを１つずつ処理する方式になろう。
１つのフォルダだけなら、FSOを使って（For Each ）
（WEB記事例）
Dim fso As FileSystemObject
Set fso = New FileSystemObject ' インスタンス化
Dim fl As Folder
Set fl = fso.GetFolder("D:\") ' フォルダを取得
Dim f As File
For Each f In fl.Files ' フォルダ内のファイルを取得
Debug.Print (f.Name) ' ファイルの名前 (Tips.txt) など　＜－－ここはシートのセルに書き出しに変える。次行も同じ。
Debug.Print (f.Path) ' ファイルのパス (D:\Tips.txt) など
Next
' 後始末
Set fso = Nothing
ーー
＞ファイルの作成日は
d = f.DateCreated
で採れるだろう。
https://www.tipsfound.com/vba/18013　参照
ーー
＞全製品のワードファイルとPDFファイル
は、ファイルの拡張子で篩にかければ仕舞い。
ーー
回答者の中にやってくれる人が出るかも。
小生は、コード作成が面倒なのと、データ実例が手元になく、ファイル実例、フォルダ実例を作るのも面倒なのと、回答者がコード作成下請けとなるので（本来有料の仕事レベル）、コード作成はしない。

お礼

ご回答ありがとうございます。
仰る通り！

アドバイス部分は理解はできても当方は具体的に使えるレベルではないのが悩みです。

回答No.2

HohoPapa

VBAでよければ
http://blog.jmiri.net/?p=1763
にコードがあります。

期待とレイアウトが違うとかがあれば指摘してください。
可能なかぎり、紹介したコードを直してポストします。

補足

いつもお世話になっております。
早々のご回答ありがとうございます。

朝よりコードを標準モジュールにコピペして、何度かトライしているのですが、VBEのツールバーから実行（R)すると空白のマクロの窓が表示されるだけで、アクティブボタンは「キャンセル」のみでこれ以上進めず。

ダメ元でNETの通り「ボタン」を作ってみましたが、マクロの登録画面に何も出てこないので登録できず。

最後に無駄なあがきと思いつつ、Sheet1にコードを張り付けて「マクロ名」を変えてみたりして、登録してみたのですが当然”×”でした。

誠にお恥ずかしながら、何か抜けていると思うので、お手数をおかけしましが、そこからご教示お願い致します。

尚、フォルダーはNET上の深いところにありますが、入力するフォルダのパスは、そのフォルダを「Shift＋右クリック」で（パスのコピー（A)）で得られる（\\aaa\bbb\ccc\ddd・・）パスでいいのですよね？

"\\Srv01\・・・\部\課\チーム\☆成績書

このフォルダの下に品名毎の「数字」「アルファベット」「50音」のフォルダがあって、その下の階層に各LOTの「成績表」がワードとPDFファイルで保存されている状況です。

いつもながら何度もお手数をかけてしまいますが、定期的な作業なので何とか少しでも簡略化したく、よろしくお願い致します。

回答No.1

papis

要は、「特定フォルダ以下のファイルリスト」を
作成できれば良いのかと解釈しました。
--
りすてぃんぐ♪
https://www.vector.co.jp/soft/win95/util/se216097.html
--
と言うソフトがあります。
かつてはファイルリスト作成機というソフトがありましたが、
開発を終了してしまいましたので、Windows10対応はこれくらいかと。

お礼

早々のご回答ありがとうございました。
ダウンロードしようとしたのですが「管理者」によって制限されているとのことで不可でした。

2か所から試みたのですが同じ結果でした。
残念！