【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