82本目：ブックのドキュメントプロパティを取得

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

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

出題：ブックのドキュメントプロパティを取得

#VBA100本ノック 82本目
フォルダ内の全てのExcelファイルについて、以下の情報（ドキュメントプロパティ等）を取得しシートへ出力してください。
A列：ファイル名
B列：作成者
C列：更新者
D列：作成日時
E列：更新日時
F列：最終印刷日
G列：サイズ
※フォルダおよび出力シートは任意

◇ 出題ページはこちら

ソースコード

定義モジュール

Option Explicit

' ファイル情報
Public Const R1stファイル情報 = 2
Public Const C1stファイル情報 = 1
Public Enum CNoファイル情報
    ファイル名 = C1stファイル情報
    作成者
    更新者
    作成日
    最終更新日時
    最終印刷日
    サイズ
End Enum
Public Const CLastファイル情報 = CNoファイル情報.サイズ

メインモジュール

Option Explicit

' 100本ノック082：ブックのドキュメントプロパティを取得
Sub フォルダ内のExcelファイルの情報を取得する()
    
    Call 指定行より下をすべて削除する(WSファイル情報, R1stファイル情報)
    
    ' ダイアログでフォルダを指定
    Dim Path指定フォルダ As String: Path指定フォルダ = GetPathダイアログボックスでフォルダを選択する
    If Path指定フォルダ = "" Then Exit Sub
    
    ' フォルダ内の全Excelファイルをコレクションに取得
    Dim Clct対象ファイル As Collection
    Set Clct対象ファイル = GetCollectionフォルダ内ファイルリスト(Path指定フォルダ, , "xls*")
    
    ' 各ファイルを開いて情報を取得
    Dim R As Long: R = R1stファイル情報
    Dim 対象ファイル As File
    For Each 対象ファイル In Clct対象ファイル
        
        Dim wb対象ファイル As Workbook
        Set wb対象ファイル = Workbooks.Open(対象ファイル.Path)
    
        On Error Resume Next
        WSファイル情報.Cells(R, CNoファイル情報.ファイル名) = 対象ファイル.Name
        WSファイル情報.Cells(R, CNoファイル情報.作成者) = wb対象ファイル.BuiltinDocumentProperties.Item("Author")
        WSファイル情報.Cells(R, CNoファイル情報.更新者) = wb対象ファイル.BuiltinDocumentProperties.Item("Last author")
        WSファイル情報.Cells(R, CNoファイル情報.作成日) = 対象ファイル.DateCreated
        WSファイル情報.Cells(R, CNoファイル情報.最終更新日時) = 対象ファイル.DateLastModified
        WSファイル情報.Cells(R, CNoファイル情報.最終印刷日) = wb対象ファイル.BuiltinDocumentProperties.Item("Last print date")
        WSファイル情報.Cells(R, CNoファイル情報.サイズ) = 対象ファイル.Size
        On Error GoTo 0
        
        R = R + 1
        
        wb対象ファイル.Close False
    Next
    
End Sub

汎用関数モジュール

Option Explicit

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

' フォルダ内のファイルリストの取得
' 参考：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
            
            ' 子フォルダへ本関数を再帰実行してDictionaryを取得
            Dim Clct子フォルダ対象ファイル As Collection
            Set Clct子フォルダ対象ファイル = GetCollectionフォルダ内ファイルリスト _
                (子フォルダ.Path, ファイルLike条件, 対象拡張子, True)
            
            ' 子フォルダのDictionaryを本関数のDictionaryと結合
            For Each ファイル In Clct子フォルダ対象ファイル
                Clct対象ファイル.Add ファイル
            Next
    
        Next ' 指定フォルダ内のすべてのファイルを走査
        
    End If
    
    ' 最終結果を返す
    Set GetCollectionフォルダ内ファイルリスト = Clct対象ファイル
End Function

' フォルダダイアログ指定
' 参考：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/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

解説

ブックの情報を取得する問題です。

FileSystemObjectのFileオブジェクトが持つ情報と、
WorkbookのBuiltinDocumentPropertyオブジェクトが持つ情報があるため、
この両方から情報を取得しています。

取得自体は簡単なコードですので、
引数のリストなどの情報はそれぞれのオブジェクトを調べてみてください。

すべてのブックをループする処理は、

• まずは対象ファイルのリストを取得
• 続いてそのリスト内の全ファイルへ実際の処理

という手順で行い、この第1工程を丸々汎用関数にしています。

こうすることで、

• ファイルの検索とファイルへの処理を別々に実装できる
• 処理が途中で停止したときにも再開しやすい
• リストを手で作って渡すなど応用が利きやすい
• ループが長大にならないためコードが読みやすい

等の様々な利点を得ることができます。

今回使った「対象ファイルをFileのCollectionとして返す関数」もなかなか便利ですので、気に入ったら一緒にお持ち帰りください。

詳しくはこちらの記事をどうぞ
[準備中]