ファイル名をエクセルにリスト化するマクロの応用

質問

ファイル名をエクセルにリスト化するマクロの応用
こんにちは。
以下に示しますマクロは
フォルダ内の名前や作成日等（サブディレクトリを含む）を
エクセルにリスト化するもので
以前同サイト内で教えて頂きました。
現在このマクロでは
シート１のAセルにフォルダのパスを入力して実行すると、
シート２にフォルダ内の情報がリスト化されます。
このマクロでは１つのフォルダ内の情報をリスト化することが可能ですが、
今回は更に、
エクセルのA列にフォルダのパスを複数個入力し、
それらのフォルダ内の情報を、それぞれ別シートに
一気にリスト化したいと考えています。
ご存じの方がいらっしゃいましたら
よろしくお願いいたします。
プログラミングに関する知識はほとんどありません…
具体的に、どこに何を入力するのかを教えていただけると嬉しいです。
お手数をおかけし、すいません。

※以下は以前nicotinismさんに回答いただいたマクロを
参考にさせていただいております。

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.6

myRange · ベストアンサー

myRangeです。

３時間ほど格闘したということですので
やる気があるとみて、回答させていただきませう。

先ず、注意点（確認事項）あり。
-------------------------------------

＞Ｄセルにシリアル番号の項目を追加し

とありますが、回答１のお礼の再質問には

＞Ａ列：ディレクトリー名
＞Ｂ列：シリアル番号
＞Ｃ列：ファイルリストが作成されているか否か

このようにＢ列が"シリアル番号"になってますよ！？

細かいことを、、、と、思うかもしれませんが、
プログラムというのは仕様に一貫性がないと書けるものではありません。
ま、自分でコードを修正加筆できれば別ですが。。

●本当にＤ列に追加した値をシート名にしていいんですね？

　　　今回もコピペすること！

'--------------------------------------------------------
Sub MakeFileList()
　Dim R As Long
　Dim NewSheet As Worksheet

　For R = 1 To Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row

　　If Sheets("Sheet1").Cells(R, "B") <> "" And _
　　　　Sheets("Sheet1").Cells(R, "C") <> "○" Then

　　　　If Dir(Sheets("Sheet1").Cells(R, "A").Value, vbDirectory) <> "" Then

　　　　On Error Resume Next
　　　　　　Set NewSheet = Sheets(Sheets("Sheet1").Cells(R, "D").Value)
　　　　　　If Err.Number = 0 Then
　　　　　　　　NewSheet.Cells.Clear
　　　　　　Else
　　　　　　　　Set NewSheet = Sheets.Add(after:=Sheets(Sheets.Count))
　　　　　　　　NewSheet.Name = Sheets("Sheet1").Cells(R, "D").Value
　　　　　　End If
　　　　On Error GoTo 0

　　　　　　Call FileList(NewSheet, Sheets("Sheet1").Cells(R, "A").Value, 0)
　　　　　　NewSheet.Range("A1:D1") = Array("Ｎｏ", "作成日", "更新日", "ファイル名")
　　　　　　NewSheet.Columns("A:D").AutoFit
　　　　　　Sheets("Sheet1").Cells(R, "C").Value = "○"
　　　　Else
　　　　　　Sheets("Sheet1").Cells(R, "C").Value = "フォルダエラー"
　　　　End If

　　End If

　Next R
　MsgBox "終了しました"
End Sub
'---------------------------------------------------------

●回答しながら感じたことを一言●
質問者には今回のコードはちょと難しいのではと思えます。
もしこれがＶＢＡの勉強ということなら
このような再起処理を使った小難しい例題ではなく
ふつうの処理から勉強すべきだと考えます。
なぜ？　このような処理をしようと思ったのでせうか？

以上です。

お礼

何度もありがとうございました。
普段はプログラミングに触れる機会がなく、
大学時に少し基礎をかじった程度で
突然フォルダの管理が必要になったため、
質問させていただきました。
最後まで丁寧に
教えていただき、とても助かりました。
ほんとうにありがとうございました。

回答No.7

myRange

続けて、myRangeです。

言い忘れあり。

●リスト作成　＞　フォルダー更新　＞　再リスト作成

この場合、既に作成されたシートを削除すると
シートの順番（左からの順番）が変わってしまうので
順番が変わらないようにするために、
回答では、シートを削除しないで、同名シートに上書きするようにしてあります。

以上です。

回答No.5

myRange

myRangeです。ちょと遅くなりましたが。。。

(1)　Ｂ１＝空白　→　何もしない
(2)　Ｂ１＝値あり　→　Ｃ１＝○＿　→　何もしない
(3)　Ｂ１＝値あり　→　Ｃ１＝空白　→　リスト作成　→　Ｃ１に○をセット

上記をＢ列最終データまで繰り返す。
●転記ミスがないように必ずコピペすること！！

'---------------------------------------------------------
Sub MakeFileList()
　Dim R As Long
　Dim NewSheet As Worksheet

　For R = 1 To Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
　　If Sheets("Sheet1").Cells(R, "B") <> "" And _
　　　 Sheets("Sheet1").Cells(R, "C") <> "○" Then

　　　 If Dir(Sheets("Sheet1").Cells(R, "A").Value, vbDirectory) <> "" Then
　　　　　Set NewSheet = Sheets.Add(after:=Sheets(Sheets.Count))
　　　　　Call FileList(NewSheet, Sheets("Sheet1").Cells(R, "A").Value, 0)
　　　　　NewSheet.Range("A1:D1").Value = Array("Ｎｏ", "作成日", "更新日", "ファイル名")
　　　　　NewSheet.Columns("A:D").AutoFit
　　　　　Sheets("Sheet1").Cells(R, "C").Value = "○"
　　　　Else
　　　　　Sheets("Sheet1").Cells(R, "C").Value = "フォルダエラー"
　　　　End If

　　End If
　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

　　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
　　End With

　　For Each objDir In objDir.SubFolders
　　　　Call FileList(NewSheet, objDir.Path, fCnt)
　　Next objDir
End Function
'-------------------------------------------

●フォルダーがNot Foundの場合には、シートは増やさずに、
　Ｃ列に”フォルダエラー"と表示するようにした。

　"フォルダエラー"と表示された場合は
　Ａ列に正しいフォルダー名を入れ再処理のこと

●Ｂ列ありで、Ａ列空白、はないということなのでＡ列空白チェックは省略
　もし、その条件がある場合は自分でやってみること

●フォルダーもファイルもNormal（普通のもの）とする

▲▲少しずつでもいいので自分でも勉強すること。。(^^;;;
以上です。

お礼

myRangeさん、思い描いた通りの結果が得られました。
ありがとうございました。
何度もすいませんが、
また問題が発生してしまいました…
Ｄセルにシリアル番号の項目を追加し、
新しく作られるシート名がシリアル番号と同じになるように、

NewSheet.Name = Sheets("Sheet1").Cells(R, "Ｄ")

という命令を追記しました。
ネットで調べて、正常に動くようになるまで
３時間もかかりましたが…汗
やっと正常に出力されるようになりました。

ここからが問題なのですが、
リストを作成した後に、
フォルダを更新し、
また新たにリストを作成したいときに、
○を消して再度マクロを実行させると、
同じ名前のシートがあるため、作成されません。
事前にＤセルのシリアル名と同じシートがあったら削除をして
新たに作成を始めるようにすることは
可能でしょうか。

いつもお疲れのところ
大変恐縮ですが、
教えてくださいお願いします。

回答No.4

ichhabehunger

言いたかないがここで勉強したことは何の役にも立ってないの?
　　　　　　　　↓
http://qanda.rakuten.ne.jp/qa6108578.html

そのものずばりの解答だけを求めていてもしかたないですよ。
質問でなくコード作成依頼になってます。

回答No.3

myRange

またまた、myRangeです。

乗りかかった船ですから今回までは面倒みませう。
が、自分でもちゃんと●勉強する●、という条件つきですが。。(^^;;;

(1)　Ｂ１＝空白　→　何もしない
(2)　Ｂ１＝値あり　→　Ｃ１＝○＿　→　何もしない
(3)　Ｂ１＝値あり　→　Ｃ１＝空白　→　リスト作成　→　Ｃ１に○をセット

上記をＢ列最終データまで繰り返す、ということでいいですね？

今から帰宅しますので回答は自宅から２１時位（遅くとも今夜中）までにはアップしておきます。
以上です。

お礼

その通りです。
本当にすいません…
よろしくお願いします。

回答No.2

imogasi

近日にも同じ質問したのでは。回答を締め切ってないらしいが、一言お礼や判らないならコメントぐらいすべきだ。
ヒントなどもらっても類推できないようでは、何度質問してみても仕方がないと思う。
ーー
A列にはフォルダ名だけ入力されるとして
Sub test01()
d = Worksheets("Sheet1").Range("A65536").End(xlUp).Row '最下行の行番号
MsgBox d
For i = 1 To d
fdn=Worksheets("Sheet1").Cells(i, "A")
'処理
MsgBox fdn
Next i
End Sub
これを事件してご覧。各行のフォルダ名が表示されるはず。
この'処理の段階でフォルダ名は文字列fnとして捉えられている。
そこでこのフォルダ名fdnを上記の関数（Function()のfileList）の引数として、あたえて実行させる
。
コードは　fileList(fdn)
この中にセルへのセットのコードが入っているのでそのまま使える。
fCntは書き出し用の行ポインターなので、続けて使っていけば良い。
シートをフォルダごとに分けるとかすると複雑になるからこのぐらいで我慢して。
上記はヒントなんでやって見るとエラーが出たりするかもしれない。
その場合はこの質問の中で行ってください。

回答No.1

myRange

あせっているのは分からんでもないですが、
同じ質問をするなら、前のは締めて再質問するのがマナーです。(^^;;;

http://okwave.jp/qa/q6112995.html

と、まあ、それは置いといて、
前の質問に回答してますのでお試しあれ。

以上です。

お礼

以後気をつけます。すいませんでした…
ついでにといっては失礼ですが、
もう一つ教えてください（><）

今回、作成していただいた
ファイルリスト作成マクロを使って、
下に示す条件のもと自動処理をしたいと思っています。

　　　Ａ　　　Ｂ Ｃ

１　　ディ　　α　　　○　　　　　　　　　　　　　　　　　　　　　　

２　　ディ　　β　　　

３

Ａ列：ディレクトリー名
Ｂ列：シリアル番号
Ｃ列：ファイルリストが作成されているか否か
　　　処理が完了していれば○、それ以外は空欄

１．エクセルの表で、Ｂ１セルが空白か否か

２．Ｂ１セルが
空白の場合→終了
シリアル番号が記入してある場合→Ｃ１セルが空白か否か

と同様の処理を）
空白の場合→ファイルリスト作成マクロ起動
　　　　　　→Ｂ２セルへ（再び１と同様の処理を）

４．Ｂセルが空欄になるまで繰り返す

※Ｂセル（シリアル番号）が入力されているときは、
Ａセル（ディレクトリ名）も記入されています。

説明がへたくそですいません。
もしわかりましたら
教えてください。よろしくお願いします。