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

質問

• 多くの製品に関する情報がフォルダに分類されて保存されています。製品名毎の成績表の作成日を一覧にする方法を教えてください。
• 各製品のフォルダ内にはワードファイルやPDFファイルといった成績表が保存されています。最新の5枚や過去2年間の作成日が分かる方法を教えてください。
• 製品名別のフォルダ内には成績表が保存されています。最新の5枚の作成日や過去2年間のファイルの作成日を一覧にする方法を教えてください。

回答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選定して閉め切ろうと思って今開けてみたら改良版が入っていました。

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

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