VBAで作るファイルリスト

TL;DL

業務で使えるのはVBAかVBScriptのみの環境で、ツールを作って作業を効率化したいと考えると、おのずとVBAで実装するしかなくなるのだけど、リモートワークだと過去に作成したものを格納しているファイルサーバーに気楽にアクセスできない。

作成頻度も多くなく毎回忘れてググるのがいい加減面倒なので、備忘として残す。

前提

・下記ソースは標準モジュールに実装する。
・マクロブックにはSheet1、Sheet2、Sheet3が存在すること。

ソースコード

Option Explicit

'### 処理起点
Sub main()
    Dim root_path As String
    root_path = ThisWorkbook.Worksheets(1).Cells(2, 1).Value
    
    '結果出力シートクリア
    With Worksheets("Sheet2")
        .Range(.Cells(2, 1), .Cells(1000, 2)).Clear
    End With
    
    With Worksheets("Sheet3")
        .Range(.Cells(2, 1), .Cells(1000, 2)).Clear
    End With

    Call make_children_list(root_path)
    MsgBox "処理完了", vbOKOnly, "処理結果"
End Sub

'### フォルダ内リスト化処理
Sub make_children_list(ByVal root_path)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'ルートフォルダのファイル一覧出力
    Call file_list(root_path, fso)
    
    Dim subfolder As Object
    For Each subfolder In fso.getfolder(root_path).subfolders
    
        'サブフォルダを持つフォルダの場合、再帰的に処理をコールする
        If fso.getfolder(subfolder).subfolders.Count > 0 Then
            Call make_children_list(subfolder)
        End If
        
        Call file_list(subfolder, fso)
    Next
    
End Sub

'### ファイルリスト化処理
Sub file_list(ByVal folder_path, ByRef fso)
    Const LASTROW = 1000
    Dim file As Object
    Dim path As String
    Dim name As String
    Dim usedrow As Integer
    Dim usedrow_rejects_file As Integer
    Dim bool_target As Boolean
    
    '出力済み最終行番号を取得
    usedrow = Worksheets("sheet2").Cells(LASTROW, 1).End(xlUp).row
    usedrow_rejects_file = Worksheets("Sheet3").Cells(LASTROW, 1).End(xlUp).row
    
    'フォルダ内のファイル情報(パス)を取得
    For Each file In fso.getfolder(folder_path).Files
        bool_target = True
        path = fso.GetParentFolderName(file)
        name = fso.GetFileName(file)
        
        bool_target = check_filetype(name, fso)
        
        '対象外拡張子に該当しなかったもののみ出力する。
        If bool_target = True Then
            usedrow = usedrow + 1
            With Worksheets("Sheet2")
                .Cells(usedrow, 1).Value = path
                .Cells(usedrow, 2).Value = name
            End With
        Else
            usedrow_rejects_file = usedrow_rejects_file + 1
            With Worksheets("Sheet3")
                .Cells(usedrow_rejects_file, 1).Value = path
                .Cells(usedrow_rejects_file, 2).Value = name
            End With
        End If
    Next
End Sub

'### 出力対象ファイル判定処理
Function check_filetype(ByVal filename, ByRef fso) As Boolean
    Dim result As Boolean: result = True
    Dim array_not_applicables As Variant
    
    '処理対象外ファイル拡張子を設定
    array_not_applicables = Array("doc", "docx", "xls", "xlsx", "txt", "ppt", "pptx", "pdf", "sql")
    
    Dim ext As Variant
    For Each ext In array_not_applicables
        If StrComp(ext, LCase(fso.GetExtensionName(filename))) = 0 Then
            result = False
            Exit For
        End If
    Next
    
    check_filetype = result
    
End Function

備考

・対象のフォルダを選択するダイアログをつけようかと思ったけど、他のマクロを作る時にも流用することを考えるとないほうが見通しがいいので今回はつけなかった。

追記(2021-05-05)

特定拡張子のファイルは一覧から除けと注文が入ったので、対象外の拡張子のファイルは別シートに一覧出力するよう変更。