【VBA】マクロでファイルリストを作る

突然ですが本業でマクロを使ったファイルリスト作成機を作りました！

この時は動けばOK程度の荒めの仕様だったのですが、せっかくなので汎用的に使えるようにもうちょっとカスタマイズしたので説明付きでこのサイトに保管します

こうやって残しておけば次必要な時にダウンロードするだけの半分自分向けですが良かったら使ってください

ツールの仕様
1. 設定項目
プログラムについて
1. 必要な参照設定
2. コピペ用プログラムの全貌
余談兼フリーソフト紹介
あとがき

ツールの仕様

VBAのことはいいからツールを使ってみたい！って方向けにまずはツールの仕様から

設定項目

絵が合った方が早いのでまずはエクセルの切り抜きから

対象フォルダ指定（グレー背景箇所）

まずは取得対象とするフォルダの指定

サブフォルダも取得するようにすると対象フォルダ以下全てのフォルダが取得対象に

ちなみにフォルダ名のところでダブルクリックするとダイアログで対象フォルダを選べる仕様にしています

フォルダ名の指定（青背景箇所）

次はフォルダ名の指定

各項目の入力条件で取得対象を制限できます

フォルダ名検索	検索したい名前を指定※パイプ文字で区切って複数指定可
一致パターン	“部分一致”、”完全一致”、”前方一致”、”後方一致”の中から選ぶ
指定 or 除外	“フォルダ名検索”,”一致パターン”に該当した時に対象とするか対象外にするか

パイプ文字は”|”のことでキーボードで言うと右上の”\”をshift押しながら押下で入力できます

ファイル名の指定（緑背景箇所）

ファイル名の指定もフォルダと同じ方法

このファイル名に拡張子は含まないので注意

拡張子の指定（オレンジ背景箇所）

フォルダ名、ファイル名の指定と同じ

.（ドット）はいらないのでエクセルなら”xlsx”でOK

プログラムについて

ここからVBAの説明に移ります

コピペでそのまま使えるプログラムと各プロシージャの説明を

必要な参照設定

フォルダ・ファイルの情報を扱うので必須レベルな”FileSystemObject“を使用しますから”Microsoft Scripting Runtime“の参照をどうぞ

その他はありませんので魔改造する時に必要に応じて

コピペ用プログラムの全貌

説明なんぞ不要でファイルがあればいい、プログラムがあればいいって方向けに最初にVBAの全プログラムとそのまま使えるマクロファイルです

長ったらしいので畳んでますが見たい方は広げてください

VBA 全プログラム

Option Explicit
Enum lngCol
    file_name = 1
    ext_name
    file_size
    create_date
    mod_date
    file_path
    file_path_split
End Enum
Dim objFso As New Scripting.FileSystemObject
Sub GetFileList()
Dim ws As Worksheet
Dim target_folder As String

'---起点フォルダの確認
target_folder = Trim(Range("TARGET_FOLDER").Value)
If objFso.FolderExists(target_folder) = False Then
    MsgBox "対象フォルダが見つかりません", vbCritical
    Exit Sub
End If

'---フォルダ名の一致判定
If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
    If Len(Trim(Range("FOLDER_MATCH_TYPE").Value)) = 0 Then
        MsgBox "フォルダ名の一致タイプ を入力してください", vbCritical
        Exit Sub
    End If
    If Len(Trim(Range("FOLDER_MATCH_PATTERN").Value)) = 0 Then
        MsgBox "フォルダ名の一致パターン を入力してください", vbCritical
        Exit Sub
    End If
Else
    Range("FOLDER_NAME").Value = Trim(Range("FOLDER_NAME").Value)
End If

'---ファイル名の一致判定
If Len(Trim(Range("FILE_NAME").Value)) > 0 Then
    If Len(Trim(Range("FILE_MATCH_TYPE").Value)) = 0 Then
        MsgBox "フォルダ名の一致タイプ を入力してください", vbCritical
        Exit Sub
    End If
    If Len(Trim(Range("FILE_MATCH_PATTERN").Value)) = 0 Then
        MsgBox "フォルダ名の一致パターン を入力してください", vbCritical
        Exit Sub
    End If
End If

'---拡張子の一致判定
If Len(Trim(Range("EXT_NAME").Value)) > 0 Then
    If Len(Trim(Range("EXT_MATCH_TYPE").Value)) = 0 Then
        MsgBox "拡張子の一致タイプ を入力してください", vbCritical
        Exit Sub
    End If
    If Len(Trim(Range("EXT_MATCH_PATTERN").Value)) = 0 Then
        MsgBox "拡張子の一致パターン を入力してください", vbCritical
        Exit Sub
    End If
End If


Set ws = Sheet2
'---テーブルをリセットする
With ws
    .Select
    '---テーブルが空だとエラーになるのでエラーを無視するようにする
    On Error Resume Next
    .Range(Range("FILE_TABLE").Address).EntireRow.Delete
    On Error GoTo 0
End With

'---まず指定フォルダのファイルを収集する
If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
    '---指定の場合一致したらファイル情報を取得する
    If Range("FOLDER_MATCH_PATTERN").Value = "指定" Then
        If in_array(objFso.GetFolder(target_folder).Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = True Then
            Call GetFileData(ws, Range("FOLDER_NAME").Value)
        End If
    End If
    '---除外の場合は不一致ならファイル情報取得して再帰処理する
    If Range("FOLDER_MATCH_PATTERN").Value = "除外" Then
        If in_array(objFso.GetFolder(target_folder).Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = False Then
            Call GetFileData(ws, Range("FOLDER_NAME").Value)
        End If
    End If
Else
    Call GetFileData(ws, Range("TARGET_FOLDER").Value)
End If


'-サブフォルダを対象とするか
If Range("TARGET_SUBFOLDER").Value = "する" Then
    Call GetSubFoler(ws, target_folder)
End If
Set ws = Nothing
Application.StatusBar = False

'---先頭行が空白だったら（絶対空白のはず）削除する
If Len(Trim(Range("FILE_TABLE").Item(1).Value)) = 0 Then
    On Error Resume Next
    Range("FILE_TABLE").ListObject.ListRows(1).Delete
    On Error GoTo 0
End If

Range("FILE_TABLE").Item(1).Select
MsgBox "終了しました"
End Sub
Sub DeleteFileList()
Dim ws As Worksheet
Set ws = Sheet2
'---テーブルをリセットする
With ws
    .Select
    On Error Resume Next
    .Range(Range("FILE_TABLE").Address).EntireRow.Delete
    On Error GoTo 0
End With
Set ws = Nothing

Range("FILE_TABLE").Item(1).Select
MsgBox "終了しました"
End Sub
Private Function GetFileData(ws As Worksheet, target_folder As String)
'======================================================================
' 指定フォルダの中にあるファイル情報を取得してリストに反映する
'======================================================================
Dim lngRow As Long
Dim file_path As String
Dim objFile As Scripting.File
Dim get_file_bool As Boolean

Application.StatusBar = target_folder & " のファイル情報を取得中・・・"
For Each objFile In objFso.GetFolder(target_folder).Files
    '---ファイルの取得判定の初期値を設定（True）
    get_file_bool = True
    '---ファイル名検索に指定があったら
    If Len(Trim(Range("FILE_NAME").Value)) > 0 Then
        '---ファイル名（拡張子除く）が条件と一致しているか確認
        If in_array(objFso.GetBaseName(objFile.Name), Split(Range("FILE_NAME").Value, "|"), Range("FILE_MATCH_TYPE").Value) = IIf(Range("FILE_MATCH_PATTERN").Value = "指定", True, False) Then
            get_file_bool = True
        Else
            get_file_bool = False
            GoTo continue
        End If
    End If
    
    '---拡張子に指定があったら
    If Len(Trim(Range("EXT_NAME").Value)) > 0 Then
        If in_array(objFso.GetExtensionName(objFile.Name), Split(Range("EXT_NAME").Value, "|"), Range("EXT_MATCH_TYPE").Value) = IIf(Range("EXT_MATCH_PATTERN").Value = "指定", True, False) Then
            get_file_bool = True
        Else
            get_file_bool = False
            GoTo continue
        End If
    End If
    
    '---取得対象と判定されたら情報を取得して書き出す
    If get_file_bool = True Then
        With ws
            .Select
            '---テーブルに行を追加する
            Range("FILE_TABLE").ListObject.ListRows.Add AlwaysInsert:=False
            lngRow = Range("FILE_TABLE").Item(Range("FILE_TABLE").Cells.Count).Row
            .Cells(lngRow, lngCol.file_name).Value = objFile.Name
            .Cells(lngRow, lngCol.ext_name).Value = objFso.GetExtensionName(objFile.Path)
            .Cells(lngRow, lngCol.file_size).Value = objFile.Size
            .Cells(lngRow, lngCol.create_date).Value = objFile.DateCreated
            .Cells(lngRow, lngCol.mod_date).Value = objFile.DateLastModified
            file_path = Replace(objFile.Path, "\" & objFile.Name, "")
            .Cells(lngRow, lngCol.file_path).Value = Replace(objFile.Path, "\" & objFile.Name, "")
            .Cells(lngRow, lngCol.file_path_split).Resize(, UBound(Split(file_path, "\")) + 1) = Split(file_path, "\")
        End With
    End If
continue:
Next
End Function
Private Function GetSubFoler(ws As Worksheet, target_folder As String)
'======================================================================
' 再帰処理でフォルダを潜りながらそのフォルダのファイルを取得する
'======================================================================
Dim objFld As Scripting.Folder

For Each objFld In objFso.GetFolder(target_folder).SubFolders
    '---フォルダ名検索に指定があったら
    If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
        '---指定の場合一致したらファイル情報を取得する
        If Range("FOLDER_MATCH_PATTERN").Value = "指定" Then
            If in_array(objFld.Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = True Then
                Call GetFileData(ws, objFld.Path)
            End If
            '---どちらにしても再帰処理はかける
            Call GetSubFoler(ws, objFld.Path)
        End If
        '---除外の場合は不一致ならファイル情報取得して再帰処理する
        If Range("FOLDER_MATCH_PATTERN").Value = "除外" Then
            If in_array(objFld.Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = False Then
                Call GetFileData(ws, objFld.Path)
                Call GetSubFoler(ws, objFld.Path)
            End If
        End If
    Else
        Call GetFileData(ws, objFld.Path)
        Call GetSubFoler(ws, objFld.Path)
    End If
Next
End Function
Private Function in_array(target_str As String, target_array As Variant, Optional match_type As String = "完全一致") As Boolean
'======================================================================
' パターンに合わせて一致判定を返す
'======================================================================
Dim arr As Variant

For Each arr In target_array
    Select Case match_type
        Case "完全一致"
            If LCase(target_str) = LCase(arr) Then
                in_array = True
                Exit Function
            End If
        Case "部分一致"
            If LCase(target_str) Like "*" & LCase(arr) & "*" Then
                in_array = True
                Exit Function
            End If
        Case "前方一致"
            If LCase(target_str) Like LCase(arr) & "*" Then
                in_array = True
                Exit Function
            End If
        Case "後方一致"
            If LCase(target_str) Like "*" & LCase(arr) Then
                in_array = True
                Exit Function
            End If
        Case Else
    End Select
Next
in_array = False
End Function

FileListMaker_v1.0 ダウンロード

ここからはプログラムをプロシージャ別に解説していきます

共通変数

Option Explicit
Enum lngCol
    file_name = 1
    ext_name
    file_size
    create_date
    mod_date
    file_path
End Enum
Dim objFso As New Scripting.FileSystemObject

個人的な話ですが、昔はプロシージャ―の外に書く共通変数にしたがっていた時期がありましたが最近はなるべく共通変数は減らして値格納する変数はNGにしています

Enum（列挙型）はExcelならではですが、列番号を宣言してあげると後から項目追加・削除したり編集する可能性があるなら便利ですよね

GetFileList（メインプロシージャ―）

Sub GetFileList()
Dim ws As Worksheet
Dim target_folder As String

'---起点フォルダの確認
target_folder = Trim(Range("TARGET_FOLDER").Value)
If objFso.FolderExists(target_folder) = False Then
    MsgBox "対象フォルダが見つかりません", vbCritical
    Exit Sub
End If

'---フォルダ名の一致判定
If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
    If Len(Trim(Range("FOLDER_MATCH_TYPE").Value)) = 0 Then
        MsgBox "フォルダ名の一致タイプ を入力してください", vbCritical
        Exit Sub
    End If
    If Len(Trim(Range("FOLDER_MATCH_PATTERN").Value)) = 0 Then
        MsgBox "フォルダ名の一致パターン を入力してください", vbCritical
        Exit Sub
    End If
Else
    Range("FOLDER_NAME").Value = Trim(Range("FOLDER_NAME").Value)
End If

'---ファイル名の一致判定
If Len(Trim(Range("FILE_NAME").Value)) > 0 Then
    If Len(Trim(Range("FILE_MATCH_TYPE").Value)) = 0 Then
        MsgBox "フォルダ名の一致タイプ を入力してください", vbCritical
        Exit Sub
    End If
    If Len(Trim(Range("FILE_MATCH_PATTERN").Value)) = 0 Then
        MsgBox "フォルダ名の一致パターン を入力してください", vbCritical
        Exit Sub
    End If
End If

'---拡張子の一致判定
If Len(Trim(Range("EXT_NAME").Value)) > 0 Then
    If Len(Trim(Range("EXT_MATCH_TYPE").Value)) = 0 Then
        MsgBox "拡張子の一致タイプ を入力してください", vbCritical
        Exit Sub
    End If
    If Len(Trim(Range("EXT_MATCH_PATTERN").Value)) = 0 Then
        MsgBox "拡張子の一致パターン を入力してください", vbCritical
        Exit Sub
    End If
End If


Set ws = Sheet2
'---テーブルをリセットする
With ws
    .Select
    '---テーブルが空だとエラーになるのでエラーを無視するようにする
    On Error Resume Next
    .Range(Range("FILE_TABLE").Address).EntireRow.Delete
    On Error GoTo 0
End With

'---まず指定フォルダのファイルを収集する
If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
    '---指定の場合一致したらファイル情報を取得する
    If Range("FOLDER_MATCH_PATTERN").Value = "指定" Then
        If in_array(objFso.GetFolder(target_folder).Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = True Then
            Call GetFileData(ws, Range("FOLDER_NAME").Value)
        End If
    End If
    '---除外の場合は不一致ならファイル情報取得して再帰処理する
    If Range("FOLDER_MATCH_PATTERN").Value = "除外" Then
        If in_array(objFso.GetFolder(target_folder).Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = False Then
            Call GetFileData(ws, Range("FOLDER_NAME").Value)
        End If
    End If
Else
    Call GetFileData(ws, Range("TARGET_FOLDER").Value)
End If


'-サブフォルダを対象とするか
If Range("TARGET_SUBFOLDER").Value = "する" Then
    Call GetSubFoler(ws, target_folder)
End If
Set ws = Nothing
Application.StatusBar = False

'---先頭行が空白だったら（絶対空白のはず）削除する
If Len(Trim(Range("FILE_TABLE").Item(1).Value)) = 0 Then
    On Error Resume Next
    Range("FILE_TABLE").ListObject.ListRows(1).Delete
    On Error GoTo 0
End If

Range("FILE_TABLE").Item(1).Select
MsgBox "終了しました"
End Sub

長いように見えてやっていることは

エクセルで入力した内容（条件）をチェックする
出力先のシート（厳密にはテーブル）をリセットする
指定したフォルダのファイル情報を取得する

だけです

当たり前ですがエクセルで設定できる項目に比例してソースが長くなってしまうのはやむなし

GetFileData

Private Function GetFileData(ws As Worksheet, target_folder As String)
'======================================================================
' 指定フォルダの中にあるファイル情報を取得してリストに反映する
'======================================================================
Dim lngRow As Long
Dim file_path As String
Dim objFile As Scripting.File
Dim get_file_bool As Boolean

Application.StatusBar = target_folder & " のファイル情報を取得中・・・"
For Each objFile In objFso.GetFolder(target_folder).Files
    '---ファイルの取得判定の初期値を設定（True）
    get_file_bool = True
    '---ファイル名検索に指定があったら
    If Len(Trim(Range("FILE_NAME").Value)) > 0 Then
        '---ファイル名（拡張子除く）が条件と一致しているか確認
        If in_array(objFso.GetBaseName(objFile.Name), Split(Range("FILE_NAME").Value, "|"), Range("FILE_MATCH_TYPE").Value) = IIf(Range("FILE_MATCH_PATTERN").Value = "指定", True, False) Then
            get_file_bool = True
        Else
            get_file_bool = False
            GoTo continue
        End If
    End If
    
    '---拡張子に指定があったら
    If Len(Trim(Range("EXT_NAME").Value)) > 0 Then
        If in_array(objFso.GetExtensionName(objFile.Name), Split(Range("EXT_NAME").Value, "|"), Range("EXT_MATCH_TYPE").Value) = IIf(Range("EXT_MATCH_PATTERN").Value = "指定", True, False) Then
            get_file_bool = True
        Else
            get_file_bool = False
            GoTo continue
        End If
    End If
    
    '---取得対象と判定されたら情報を取得して書き出す
    If get_file_bool = True Then
        With ws
            .Select
            '---テーブルに行を追加する
            Range("FILE_TABLE").ListObject.ListRows.Add AlwaysInsert:=False
            lngRow = Range("FILE_TABLE").Item(Range("FILE_TABLE").Cells.Count).Row
            .Cells(lngRow, lngCol.file_name).Value = objFile.Name
            .Cells(lngRow, lngCol.ext_name).Value = objFso.GetExtensionName(objFile.Path)
            .Cells(lngRow, lngCol.file_size).Value = objFile.Size
            .Cells(lngRow, lngCol.create_date).Value = objFile.DateCreated
            .Cells(lngRow, lngCol.mod_date).Value = objFile.DateLastModified
            file_path = Replace(objFile.Path, "\" & objFile.Name, "")
            .Cells(lngRow, lngCol.file_path).Value = Replace(objFile.Path, "\" & objFile.Name, "")
            .Cells(lngRow, lngCol.file_path_split).Resize(, UBound(Split(file_path, "\")) + 1) = Split(file_path, "\")
        End With
    End If
continue:
Next
End Function

まず今回のようなループが多いプログラムはステータスバーに進捗状況を表示してあげると親切

他の言語に慣れるとVBAのForループにcontinueが無いのが地味にストレスなんでGoToで無理矢理再現したことと、PHPで出会ったin_arrayは後述していますがVBAにない関数は自作してしまえってことでこちらも再現しただけの関数を準備しました

他には出力先をテーブル化しているので最下行の指定が通例とちょっと違うことと、フォルダパスを”\”で区切った配列を一気に反映させるためにResizeを使っているところがミソ

細かいこと書きましたがざっくりやっていることは↓↓だけ

引数にあるフォルダ内のファイルをFor Eachでサーチ
SETシートで指定したファイルと拡張子の条件と照合
条件一致していればLISTシートにあるテーブルへ書き込む

GetSubFoler

Private Function GetSubFoler(ws As Worksheet, target_folder As String)
'======================================================================
' 再帰処理でフォルダを潜りながらそのフォルダのファイルを取得する
'======================================================================
Dim objFld As Scripting.Folder

For Each objFld In objFso.GetFolder(target_folder).SubFolders
    '---フォルダ名検索に指定があったら
    If Len(Trim(Range("FOLDER_NAME").Value)) > 0 Then
        '---指定の場合一致したらファイル情報を取得する
        If Range("FOLDER_MATCH_PATTERN").Value = "指定" Then
            If in_array(objFld.Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = True Then
                Call GetFileData(ws, objFld.Path)
            End If
            '---どちらにしても再帰処理はかける
            Call GetSubFoler(ws, objFld.Path)
        End If
        '---除外の場合は不一致ならファイル情報取得して再帰処理する
        If Range("FOLDER_MATCH_PATTERN").Value = "除外" Then
            If in_array(objFld.Name, Split(Range("FOLDER_NAME").Value, "|"), Range("FOLDER_MATCH_TYPE").Value) = False Then
                Call GetFileData(ws, objFld.Path)
                Call GetSubFoler(ws, objFld.Path)
            End If
        End If
    Else
        Call GetFileData(ws, objFld.Path)
        Call GetSubFoler(ws, objFld.Path)
    End If
Next
End Function

ここでもin_arrayが登場してるのですが、条件指定を複数できるようにしてるので重宝します

ここでのポイントは再帰処理しているところだけで、これまで通りやっていることを並べると

SETシートで指定したフォルダの条件と照合
一致しているもしくは条件指定していないならファイル情報を取得
次の階層のフォルダを同じことを繰り返す

再帰処理はその内説明ページ作ります

in_array

Private Function in_array(target_str As String, target_array As Variant, Optional match_type As String = "完全一致") As Boolean
'======================================================================
' パターンに合わせて一致判定を返す
'======================================================================
Dim arr As Variant

For Each arr In target_array
    Select Case match_type
        Case "完全一致"
            If LCase(target_str) = LCase(arr) Then
                in_array = True
                Exit Function
            End If
        Case "部分一致"
            If LCase(target_str) Like "*" & LCase(arr) & "*" Then
                in_array = True
                Exit Function
            End If
        Case "前方一致"
            If LCase(target_str) Like LCase(arr) & "*" Then
                in_array = True
                Exit Function
            End If
        Case "後方一致"
            If LCase(target_str) Like "*" & LCase(arr) Then
                in_array = True
                Exit Function
            End If
        Case Else
    End Select
Next
in_array = False
End Function

本家のin_arrayは完全一致だけですが今回の使用目的的にも自作関数なので一致条件を分岐で作りましたが、指定の文字が配列の中にあるかをチェックする関数

Dictionary型で無理矢理取り扱えばExistsもありますが、完全一致以外も処理したいので結局自作関数がベストかと