複数のフォルダ内の名前や作成日等をリスト化する方法

質問

複数のフォルダ内の名前や作成日等をリスト化する方法
こんにちは。
以下に示しますマクロは
フォルダ内の名前や作成日等（サブディレクトリを含む）をリスト化するもので
以前同サイト内で教えて頂きました。
現在このマクロでは
シート１のAセルにフォルダのパスを入力して実行すると、
シート２にフォルダ内の情報がリスト化されます。
このマクロでは１つのフォルダ内の情報をリスト化することが可能ですが、
今回は更に、
エクセルのA列にフォルダのパスを複数個入力し、
それらのフォルダ内の情報を、それぞれ別シートに
一気にリスト化したいと考えています。
ご存じの方がいらっしゃいましたら
よろしくお願いいたします。

Sub makeFileList()
　　Call fileList
　　MsgBox "終了しました"
Columns.AutoFit 'すべての列幅を自動調整する
End Sub

Function fileList(Optional trgDir As String = "", Optional fCnt As Long = 0)
　　On Error GoTo err
　　Dim objFs As Object
　　Dim objDir As Object
　　Dim objFile As Object
　　Dim i As Long

　　Set objFs = CreateObject("Scripting.FileSystemObject")

　　If trgDir = "" Then
　　　　Set objDir = objFs.Getfolder(Sheets("sheet1").Range("a1"))
　　Else
　　　　Set objDir = objFs.Getfolder(trgDir)
　　End If

　　Set objFile = objDir.Files

　　With Sheets("sheet2")
　　　　For Each objFile In objDir.Files
　　　　　　　　fCnt = fCnt + 1
.Cells(fCnt, 1).Offset(1, 0) = fCnt
.Cells(fCnt, 2).Offset(1, 0) = objFile.DateCreated
.Cells(fCnt, 3).Offset(1, 0) = objFile.DateLastModified
.Cells(fCnt, 4).Offset(1, 0) = objFile.Path
.Range("A1").Value = "Ｎｏ"
.Range("B1").Value = "作成日"
.Range("C1").Value = "更新日"
.Range("D1").Value = "ファイル名"
　　　　Next objFile

　　　　For Each objDir In objDir.SubFolders
　　　　　　If objDir.Attributes <> 22 Then　　 'システムフォルダ除外

　　　　　　　　　　'--------------サブフォルダの再帰検索
　　　　　　　　　　　　Call fileList(objDir.Path, fCnt)
　　　　　　　　　　'--------------サブフォルダの再帰検索

　　　　　　End If
　　　　Next objDir
　　End With

　　Set objFile = Nothing
　　Set objDir = Nothing
　　Set objFs = Nothing
Exit Function

err:
　　Select Case err.Number
　　　　Case 76 ' path がない
　　　　　　MsgBox "path 指定が間違っています"
　　　　Case Else
　　　　　　MsgBox err.Number & vbCrLf & err.Description
　　End Select

　　Set objFile = Nothing
　　Set objDir = Nothing
　　Set objFs = Nothing
End Function

回答No.3

myRange · ベストアンサー

回答２、myRangeです。

変数宣言が抜けてますねぇ、、すみませぬ。。(^^;;;

下記、●●の一行を追加願います。

'---------------------------------------
Sub MakeFileList()

　Dim NewSheet As Worksheet　　'●●これを追加する

　Dim R As Long

　For R = 1 To Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
　　　Set NewSheet = Sheets.Add(after:=Sheets(Sheets.Count))
　　　NewSheet.Range("A1:D1") = Array("Ｎｏ", "作成日", "更新日", "ファイル名")
　　　Call FileList(NewSheet, Sheets("Sheet1").Cells(R, "A").Value, 0)
　　　NewSheet.Columns("A:D").AutoFit
　Next R
　MsgBox "終了しました"
End Sub
'--------------------------------------

以上です。

お礼

感動です！
ありがとうございました。
急いでいましたが、これで間に合いそうです。
天才ですね！！

回答No.2

myRange

（処理内容）
Sheet１のＡ列にディレクトリー名が入力してあるものとする
Ａ１～Ａ最終行までひとつずつ検索し、別シートに内容を表示する
別シートは【自動】で増やす
該当がない場合は、増やしたシートにその旨表示。

'--------------------------------------------------------
Sub MakeFileList()
　　Dim R As Long
　　For R = 1 To Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
　　　　Set NewSheet = Sheets.Add(after:=Sheets(Sheets.Count))
　　　　NewSheet.Range("A1:D1") = Array("Ｎｏ", "作成日", "更新日", "ファイル名")
　　　　Call FileList(NewSheet, Sheets("Sheet1").Cells(R, "A").Value, 0)
　　　　NewSheet.Columns("A:D").AutoFit
　　Next R
　　MsgBox "終了しました"
End Sub
'---------------------------------------------------------　
Function FileList(NewSheet As Worksheet, trgDir As String, fCnt As Long)
　　Dim objFs As Object
　　Dim objDir As Object
　　Dim objFile As Object
　　Dim i As Long

　　On Error GoTo ErrRtn

　　Set objFs = CreateObject("Scripting.FileSystemObject")
　　　　Set objDir = objFs.Getfolder(trgDir)
　　　　Set objFile = objDir.Files

　　With NewSheet
　　　　For Each objFile In objDir.Files
　　　　　　fCnt = fCnt + 1
　　　　　　.Cells(Fcnt, 1).Offset(1, 0) = Fcnt
　　　　　　.Cells(Fcnt, 2).Offset(1, 0) = objFile.DateCreated
　　　　　　.Cells(Fcnt, 3).Offset(1, 0) = objFile.DateLastModified
　　　　　　.Cells(Fcnt, 4).Offset(1, 0) = objFile.Path
　　　　Next objFile　
　　　　For Each objDir In objDir.SubFolders
　　　　　　If objDir.Attributes <> 22 Then　　 'システムフォルダ除外
　　　　　　　　Call FileList(NewSheet, objDir.Path, fCnt)
　　　　　　End If
　　　　Next objDir
　　End With
Exit Function

ErrRtn:
　　NewSheet.Range("B4").Value = trgDir & "　は無し！"
　　NewSheet.Range("B4").Font.Size = 24
End Function
'-------------------------------------------

以上です。

お礼

回答ありがとうございます。
早速走らせてみたところ、
「コンパイルエラー：ＢｙＲｅｆ引数の型が一致しません」
と出てしまいます。
エクセルＳｈｅｅｔ１のＡセルにディレクトリー名は入力しました。
それ以外にどこかいじるところがあるのでしょうか。
初歩的なことかもしれませんが、
教えていただけないでしょうか。
よろしくお願いいたします。

回答No.1

imogasi

コードは随分きっちりした正統な書き方のコードの回答です。
それだけに初心者には要点が判りにくいかも。
この質問はどちらかと言うと、回答がVBSを使っているために、VBSの関連質問になっている。
これが本質問のケースに応用できないようでは、この質問の回答をもらっても場合によっては役立たないようにおもう。中身も含めてわかるように勉強すべきだ。
この関数は
objFs.Getfolder(Sheets("sheet1").Range("a1"))
Set objDir = objFs.Getfolder(trgDir)
でtrgDirという引数の指定なければ前者、Sheet1のA1セルの値であるフォルダ名のフォルダを
指定あれば後者でtrgDirというフォルダを対象にしているから、
本質問の場合は、ここのtrgDirの指定を、＞パスを複数個入力したシートの、次々のセルの値（をForNextなど使って）にずらして、回答全体を繰り返せば（この関数を使えば、この関数に飛んでくれば）仕舞い。
またfCntという書き出す行ポインターの変数は、作業中は連続したほうが良かろうから、関数の外に出して続けた方が良い。

補足

回答ありがとうございます。
少しずつ勉強していきたいと思います。
現在、そのマクロ作成を急いでおり、
具体的にどこをどう直すかを教えていただけないでしょうか。
決して楽をしようとしている訳ではありませんが、
全くの初心者で、期日までに間に合わせなければならないので…
また、フォルダ情報をエクセルに出力する際、
セルの幅を自動調節するため４行めに自分で
Columns.AutoFit
を挿入しましたが、この挿入場所は正しいでしょうか。
教えてください。
よろしくお願いします。