フォルダ内のファイル名一覧取得

'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

'■フォルダ構成：thiswoorkbook(実行ブック)と同じ階層に処理対象フォルダ

'■パブリック変数を使いたくないので、直接「ファイル名一覧」シートに書き出す。

'■最後のFSO開放はループ重複するがが平気そうなので気にしないことにする。

’■microsoft runtime 事前に登録しておく。

’■sub ファイル名リスト作成（[フォルダパス]、[サブフォルダ探索要否]、[拡張子

'■指定]）。省略すると、処理対象フォルダ、サブフォルダ探索なし、拡張子指定なし。

’■本当は汎用性のために配列に入れていおいてから、シートに書き出す形にして、

’■シート書き出しは必要に応じてコメント化する形にしたかったが、サブフォルダまで

’■探査する場合に配列の要素数の求め方が分からずやめた。シートに書き出すのは実

’■現できたのでよしとする。

'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

----------------------------------------------------------------------------------------------------------------------

Option Explicit

Sub TOTAL()
Call ファイル名リスト作成準備
Call ファイル名リスト作成(ThisWorkbook.path & "¥処理対象", 1, "")
End Sub

----------------------------------------------------------------------------------------------------------------------
Sub ファイル名リスト作成準備()
'「ファイル名一覧」シートが存在しなかったら作る
On Error Resume Next
ThisWorkbook.Sheets("ファイル名一覧").Name = ThisWorkbook.Sheets("ファイル名一覧").Name
On Error GoTo 0
If Err.Number > 0 Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = "ファイル名一覧"
Err.Clear
End If

'ファイル名一覧シートを初期化して、1行目に見出しを作る
With ThisWorkbook.Sheets("ファイル名一覧")
.Cells.Clear
.Range("A1") = "パス"
.Range("B1") = "ファイル名"
.Range("C1") = "ファイル名(拡張子なし)"
.Range("D1") = "拡張子名"
End With
End Sub

-------------------------------------------------------------------------------------------------------------------

Sub ファイル名リスト作成(myPath As String, Optional SubFolderFlag As Long = 0, Optional myExtensionName As String = "")
Dim FSO As New FileSystemObject

'デフォルトフォルダは処理対象フォルダとする。
If myPath = "" Then
myPath = ThisWorkbook.path & "￥処理対象"
End If

'まず当該フォルダ直下のファイルについて全部書き出す
Dim f As File
For Each f In FSO.GetFolder(myPath).Files '当該フォルダ直下の全ファイル
'拡張子指定なしのとき
If myExtensionName = "" Then
With ThisWorkbook.Sheets("ファイル名一覧").Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0) = f.path 'ファイル名
.Offset(1, 1) = f.Name 'ファイル名
.Offset(1, 2) = FSO.GetBaseName(f.Name) 'ファイル名（拡張子なし）
.Offset(1, 3) = FSO.GetExtensionName(f.Name) '拡張子名
End With
'拡張子指定ありのとき
Else
If LCase(FSO.GetExtensionName(f.Name)) = myExtensionName Then
With ThisWorkbook.Sheets("ファイル名一覧").Cells(Rows.Count, 1).End(xlUp) '見出し行がないと0件のときズレる
.Offset(1, 0) = f.path 'パス
.Offset(1, 1) = f.Name 'ファイル名
.Offset(1, 2) = FSO.GetBaseName(f.Name) 'ファイル名（拡張子なし）
.Offset(1, 3) = FSO.GetExtensionName(f.Name) '拡張子名
End With
End If
End If
Next f

'サブフォルダ内も書き出す場合
If SubFolderFlag = 1 Then
Dim mySubFolder As Folder
For Each mySubFolder In FSO.GetFolder(myPath).SubFolders 'サブフォルダがあったら
Call ファイル名リスト作成(mySubFolder.path, 1, myExtensionName) 'そのサブフォルダを引数にして自分自身を呼び出す
Next mySubFolder
End If

Set FSO = Nothing '開放
End Sub