26本目：ファイル一覧作成

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：ファイル一覧作成

#VBA100本ノック 26本目
フォルダ選択のダイアログでフォルダを指定し、フォルダ内にあるファイルの一覧を「ファイル一覧」シートのA列に出力してください。
・ファイル名,更新日時,サイズ※画像参照
・Excelファイル(xls,xlsx,xlsm)にはハイパーリンクを設定
※サブフォルダは不要です。

◇ 出題ページはこちら

FileSystemObject利用バージョン

定義モジュール

Option Explicit

' ファイル一覧
Public Const R1stファイル一覧 = 2
Public Const C1stファイル一覧 = 1
Public Enum CNoファイル一覧
    ファイル名 = C1stファイル一覧
    更新日時
    サイズ
End Enum
Public Const CLastファイル一覧 = CNoファイル一覧.サイズ

メインモジュール

Option Explicit

' 100本ノック026：ファイル一覧作成
Sub ダイアログで指定されたフォルダ内のファイルリストを作成する_FSO版()

    Call 指定行より下をすべて削除する(WSファイル一覧, R1stファイル一覧)
    
    ' ダイアログでフォルダパスを指定
    Dim path指定フォルダ As String
    path指定フォルダ = GetPathダイアログボックスでフォルダを選択する(ThisWorkbook.Path)
    If path指定フォルダ = "" Then Exit Sub
    
    ' フォルダ内のすべてのファイルをループ
    Dim R As Long: R = R1stファイル一覧
    Dim ファイル As File
    For Each ファイル In FSO.GetFolder(path指定フォルダ).Files
        
        ' ファイル情報の出力
        WSファイル一覧.Cells(R, CNoファイル一覧.ファイル名) = ファイル.Name
        WSファイル一覧.Cells(R, CNoファイル一覧.更新日時) = ファイル.DateLastModified
        WSファイル一覧.Cells(R, CNoファイル一覧.サイズ) = Fx.RoundUp(ファイル.Size / 1024, 0)
        
        ' Excelファイルならハイパーリンクを設置
        If FSO.GetExtensionName(ファイル.Name) Like "xls*" And _
           Not ファイル.Name Like "~$*" Then ' 編集中を制御するための一時ファイルもリンク対象外とする
            WSファイル一覧.Hyperlinks.Add Anchor:=WSファイル一覧.Cells(R, CNoファイル一覧.ファイル名), Address:=ファイル.Path
        End If
        
        R = R + 1
    Next
    
End Sub

汎用関数モジュール

Option Explicit

' FileSystemObjectの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-filesystemobject
Public FSO As New FileSystemObject

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' 指定行より下の削除
' 参考：https://www.limecode.jp/entry/utility/delete-rows-below-to-last
Sub 指定行より下をすべて削除する(対象シート As Worksheet, 指定行 As Long)
    With 対象シート
    
        Call フィルターをクリアする(対象シート)
        
        .Range(.Rows(指定行), .Rows(.Rows.Count)).Delete
        
    End With
End Sub

' フィルターのクリア
' ◆ ブログ未掲載
Sub フィルターをクリアする(対象シート As Worksheet)
    If 対象シート.AutoFilterMode = True Then
        If 対象シート.AutoFilter.FilterMode = True Then
            対象シート.AutoFilter.ShowAllData
        End If
    End If
End Sub

' フォルダダイアログ指定
' 参考：https://www.limecode.jp/entry/utility/filedialog-folder
Function GetPathダイアログボックスでフォルダを選択する(Optional Path初期表示フォルダ As String = "") As String
    With Application.FileDialog(msoFileDialogFolderPicker)

        If Path初期表示フォルダ <> "" Then .InitialFileName = Path初期表示フォルダ

        If .Show Then: GetPathダイアログボックスでフォルダを選択する = .SelectedItems(1)
    
    End With
End Function

Dir関数利用バージョン

※ 定義モジュール・汎用関数モジュールは全く同じものです。

定義モジュール

Option Explicit

' ファイル一覧
Public Const R1stファイル一覧 = 2
Public Const C1stファイル一覧 = 1
Public Enum CNoファイル一覧
    ファイル名 = C1stファイル一覧
    更新日時
    サイズ
End Enum
Public Const CLastファイル一覧 = CNoファイル一覧.サイズ

メインモジュール

' 100本ノック026：ファイル一覧作成
Sub ダイアログで指定されたフォルダ内のファイルリストを作成する_Dir版()

    Call 指定行より下をすべて削除する(WSファイル一覧, R1stファイル一覧)
    
    ' ダイアログでフォルダパスを指定
    Dim path指定フォルダ As String
    path指定フォルダ = GetPathダイアログボックスでフォルダを選択する(ThisWorkbook.Path)
    If path指定フォルダ = "" Then Exit Sub
    
    ' フォルダ内のすべてのファイルをループ
    Dim R As Long: R = R1stファイル一覧
    Dim dirファイル名 As String
    dirファイル名 = Dir(path指定フォルダ & "\*")
    Do Until dirファイル名 = ""
        
        Dim ファイルパス As String
        ファイルパス = path指定フォルダ & "\" & dirファイル名
        
        ' ファイル情報の出力
        WSファイル一覧.Cells(R, CNoファイル一覧.ファイル名) = dirファイル名
        WSファイル一覧.Cells(R, CNoファイル一覧.更新日時) = FileDateTime(ファイルパス)
        WSファイル一覧.Cells(R, CNoファイル一覧.サイズ) = Fx.RoundUp(FileLen(ファイルパス) / 1024, 0)
        
        ' Excelファイルならハイパーリンクを設置
        If FSO.GetExtensionName(dirファイル名) Like "xls*" And _
           Not dirファイル名 Like "~$*" Then ' 編集中を制御するための一時ファイルもリンク対象外とする
            WSファイル一覧.Hyperlinks.Add Anchor:=WSファイル一覧.Cells(R, CNoファイル一覧.ファイル名), Address:=ファイルパス
        End If
        
        R = R + 1
        dirファイル名 = Dir()
    Loop
    
End Sub

汎用関数モジュール

Option Explicit

' FileSystemObjectの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-filesystemobject
Public FSO As New FileSystemObject

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' 指定行より下の削除
' 参考：https://www.limecode.jp/entry/utility/delete-rows-below-to-last
Sub 指定行より下をすべて削除する(対象シート As Worksheet, 指定行 As Long)
    With 対象シート
    
        Call フィルターをクリアする(対象シート)
        
        .Range(.Rows(指定行), .Rows(.Rows.Count)).Delete
        
    End With
End Sub

' フィルターのクリア
' ◆ ブログ未掲載
Sub フィルターをクリアする(対象シート As Worksheet)
    If 対象シート.AutoFilterMode = True Then
        If 対象シート.AutoFilter.FilterMode = True Then
            対象シート.AutoFilter.ShowAllData
        End If
    End If
End Sub

' フォルダダイアログ指定
' 参考：https://www.limecode.jp/entry/utility/filedialog-folder
Function GetPathダイアログボックスでフォルダを選択する(Optional Path初期表示フォルダ As String = "") As String
    With Application.FileDialog(msoFileDialogFolderPicker)

        If Path初期表示フォルダ <> "" Then .InitialFileName = Path初期表示フォルダ

        If .Show Then: GetPathダイアログボックスでフォルダを選択する = .SelectedItems(1)
    
    End With
End Function

ライブラリ利用バージョン

定義モジュール

Option Explicit

' ファイル一覧
Public Const R1stファイル一覧 = 2
Public Const C1stファイル一覧 = 1
Public Enum CNoファイル一覧
    ファイル名 = C1stファイル一覧
    更新日時
    サイズ
End Enum
Public Const CLastファイル一覧 = CNoファイル一覧.サイズ

メインモジュール

Option Explicit

' 100本ノック026：ファイル一覧作成
Sub ダイアログで指定されたフォルダ内のファイルリストを作成する_ライブラリ版()

    Call 指定行より下をすべて削除する(WSファイル一覧, R1stファイル一覧)
    
    ' ダイアログでフォルダパスを指定
    Dim path指定フォルダ As String
    path指定フォルダ = GetPathダイアログボックスでフォルダを選択する(ThisWorkbook.Path)
    If path指定フォルダ = "" Then Exit Sub
    
    ' 対象ファイルのコレクションを取得
    Dim Clctファイルリスト As Collection
    Set Clctファイルリスト = GetCollectionフォルダ内ファイルリスト(path指定フォルダ, , "*")
    
    ' フォルダ内のすべてのファイルをループ
    Dim R As Long: R = R1stファイル一覧
    Dim ファイル As File
    For Each ファイル In Clctファイルリスト
        
        ' ファイル情報の出力
        WSファイル一覧.Cells(R, CNoファイル一覧.ファイル名) = ファイル.Name
        WSファイル一覧.Cells(R, CNoファイル一覧.更新日時) = ファイル.DateLastModified
        WSファイル一覧.Cells(R, CNoファイル一覧.サイズ) = Fx.RoundUp(ファイル.Size / 1024, 0)
        
        ' Excelファイルならハイパーリンクを設置
        If FSO.GetExtensionName(ファイル.Name) Like "xls*" And _
           Not ファイル.Name Like "~$*" Then ' 編集中を制御するための一時ファイルもリンク対象外とする
            WSファイル一覧.Hyperlinks.Add Anchor:=WSファイル一覧.Cells(R, CNoファイル一覧.ファイル名), Address:=ファイル.Path
        End If
        
        R = R + 1
    Next
    
End Sub

汎用関数モジュール

Option Explicit

' FileSystemObjectの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-filesystemobject
Public FSO As New FileSystemObject

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' 指定行より下の削除
' 参考：https://www.limecode.jp/entry/utility/delete-rows-below-to-last
Sub 指定行より下をすべて削除する(対象シート As Worksheet, 指定行 As Long)
    With 対象シート
    
        Call フィルターをクリアする(対象シート)
        
        .Range(.Rows(指定行), .Rows(.Rows.Count)).Delete
        
    End With
End Sub

' フィルターのクリア
' ◆ ブログ未掲載
Sub フィルターをクリアする(対象シート As Worksheet)
    If 対象シート.AutoFilterMode = True Then
        If 対象シート.AutoFilter.FilterMode = True Then
            対象シート.AutoFilter.ShowAllData
        End If
    End If
End Sub

' フォルダダイアログ指定
' 参考：https://www.limecode.jp/entry/utility/filedialog-folder
Function GetPathダイアログボックスでフォルダを選択する(Optional Path初期表示フォルダ As String = "") As String
    With Application.FileDialog(msoFileDialogFolderPicker)

        If Path初期表示フォルダ <> "" Then .InitialFileName = Path初期表示フォルダ

        If .Show Then: GetPathダイアログボックスでフォルダを選択する = .SelectedItems(1)
    
    End With
End Function

' フォルダ内のファイルリストの取得
' 参考：https://www.limecode.jp/entry/utility/get-file-list-function-in-folder
Function GetCollectionフォルダ内ファイルリスト(Path対象フォルダ As String _
    , Optional ByVal ファイルLike条件 As String = "*", Optional 対象拡張子 As String = "xlsx" _
    , Optional is下層フォルダまで取得 As Boolean = False) As Collection
    
    ' ファイルが存在しなくても空のコレクションは返す(Nothingは返さない)
    Set GetCollectionフォルダ内ファイルリスト = New Collection
    
    ' 返り値用コレクション
    Dim Clct対象ファイル As New Collection
    
    ' 対象フォルダを取得
    If FSO.FolderExists(Path対象フォルダ) = False Then Exit Function
    Dim 対象フォルダ As Folder
    Set 対象フォルダ = FSO.GetFolder(Path対象フォルダ)

    ' 指定フォルダ内のすべてのファイルを走査
    Dim ファイル As File
    For Each ファイル In 対象フォルダ.Files
        
        ' 条件を満たすファイルの情報をCollectionに格納
        If ファイル.Name Like ファイルLike条件 & "." & 対象拡張子 Then
            Clct対象ファイル.Add ファイル
        End If

    Next ' 指定フォルダ内のすべてのファイルを走査
    
    ' 下層フォルダも取得する場合の再帰処理
    If is下層フォルダまで取得 Then
        
        Dim 子フォルダ As Folder
        For Each 子フォルダ In 対象フォルダ.SubFolders
            
            ' 子フォルダへ本関数を再帰呼出してCollectionを取得
            Dim Clct子フォルダ対象ファイル As Collection
            Set Clct子フォルダ対象ファイル = GetCollectionフォルダ内ファイルリスト _
                (子フォルダ.Path, ファイルLike条件, 対象拡張子, True)
            
            ' 子フォルダのCollectionを本関数のCollectionと結合
            For Each ファイル In Clct子フォルダ対象ファイル
                Clct対象ファイル.Add ファイル
            Next
    
        Next ' 指定フォルダ内のすべてのファイルを走査
        
    End If
    
    ' 最終結果を返す
    Set GetCollectionフォルダ内ファイルリスト = Clct対象ファイル
End Function

解説