プロパティやシートのヘッダやフッタを出力するマクロ

エクセルのプロパティやシートの情報を取得するマクロを ガッと書きなぐってみた。

ほとんどChatGPTにベースは書いてもらっているけど。

Sub RecursiveGetExcelFileInfo(FolderPath As String, ByRef OutputRow As Long)
    Dim FileName As String
    Dim ExtName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim OutputCol As Long
    
    Debug.Print "[RecursiveGetExcelFileInfo][BEGIN]" & FolderPath
    
    ' FileSystemObject を作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(FolderPath)
    
    ' フォルダ内の全てのファイルに対してループ
    For Each file In folder.Files
        FileName = fso.GetFileName(file.Name)
        ExtName = fso.GetExtensionName(file.Name)
        Debug.Print FileName
        If (FileName <> ".") And (FileName <> "..") And (FileName <> ThisWorkbook.Name) And Not (FileName Like "~$*") Then
            If LCase(ExtName) = "xls" Or _
               LCase(ExtName) = "xlsx" Or _
               LCase(ExtName) = "xlsm" Then
                
                Application.ScreenUpdating = False
                
                ' エクセルファイルの場合、処理
                Set wb = Workbooks.Open(FolderPath & FileName, , True)
                
                ' エクセルファイルのプロパティを出力
                Cells(OutputRow, 1).Value = FolderPath
                Cells(OutputRow, 2).Value = FileName
                Cells(OutputRow, 3).Value = wb.BuiltinDocumentProperties("Author")
                Cells(OutputRow, 4).Value = wb.BuiltinDocumentProperties("Last Author")
                Cells(OutputRow, 5).Value = wb.BuiltinDocumentProperties("Company")
                Cells(OutputRow, 6).Value = wb.ActiveSheet.Name
                
                ' 各シートに対してループ
                For Each ws In wb.Sheets
                    OutputCol = 7
                    ' ヘッダ・フッタ情報を出力
                    Cells(OutputRow, OutputCol).Value = ws.Name
                    Cells(OutputRow, OutputCol + 1).Value = CBool(ws.Visible)
                    ws.Activate
                    Cells(OutputRow, OutputCol + 2).Value = ActiveCell.AddressLocal(RowAbsolute:=False, ColumnAbsolute:=False, ReferenceStyle:=xlA1)
                    Cells(OutputRow, OutputCol + 3).Value = Selection.AddressLocal(RowAbsolute:=False, ColumnAbsolute:=False, ReferenceStyle:=xlA1)
                    
                    OutputCol = OutputCol + 4
                    Cells(OutputRow, OutputCol).Value = ws.PageSetup.LeftHeader
                    Cells(OutputRow, OutputCol + 1).Value = ws.PageSetup.CenterHeader
                    Cells(OutputRow, OutputCol + 2).Value = ws.PageSetup.RightHeader
                    Cells(OutputRow, OutputCol + 3).Value = ws.PageSetup.LeftFooter
                    Cells(OutputRow, OutputCol + 4).Value = ws.PageSetup.CenterFooter
                    Cells(OutputRow, OutputCol + 5).Value = ws.PageSetup.RightFooter
                    
                    ' 出力行を次に進める
                    OutputRow = OutputRow + 1
                Next ws
                
                ' エクセルファイルを閉じる
                wb.Close SaveChanges:=False
            
                Application.ScreenUpdating = True
                DoEvents
            End If
        End If
    Next file
    
    ' サブフォルダに対して再帰処理
    For Each folder In folder.SubFolders
        RecursiveGetExcelFileInfo folder.Path & "\", OutputRow
    Next folder
    
    Debug.Print "[RecursiveGetExcelFileInfo][END]" & FolderPath


End Sub

Sub ResetOutput()
    Dim OutputRow As Long
    Dim EndRow As Long
    OutputRow = 2
    EndRow = Rows.Count
    Range(Cells(OutputRow, 1), Cells(EndRow, 100)).Delete (xlShiftUp)
    Application.ScreenUpdating = True
End Sub

Sub StartRecursiveProcessing()
    Dim dlg As FileDialog
    Dim FolderPath As String
    Dim OutputRow As Long
    Dim OutputCol As Long
    Dim startTime As Double
    Dim endTime As Double
    Dim elapsedTime As Double
    
    ResetOutput
    
    ' ヘッダ出力
    OutputRow = 1
    Cells(OutputRow, 1).Value = "FolderPath"
    Cells(OutputRow, 2).Value = "FileName"
    Cells(OutputRow, 3).Value = "Author"
    Cells(OutputRow, 4).Value = "Last Author"
    Cells(OutputRow, 5).Value = "Company"
    Cells(OutputRow, 6).Value = "ActiveSheet"
    OutputCol = 7
    Cells(OutputRow, OutputCol).Value = "SheetName"
    Cells(OutputRow, OutputCol + 1).Value = "Visible"
    Cells(OutputRow, OutputCol + 2).Value = "ActiveCell"
    Cells(OutputRow, OutputCol + 3).Value = "Selection"
    
    OutputCol = OutputCol + 4
    Cells(OutputRow, OutputCol).Value = "LeftHeader"
    Cells(OutputRow, OutputCol + 1).Value = "CenterHeader"
    Cells(OutputRow, OutputCol + 2).Value = "RightHeader"
    Cells(OutputRow, OutputCol + 3).Value = "LeftFooter"
    Cells(OutputRow, OutputCol + 4).Value = "CenterFooter"
    Cells(OutputRow, OutputCol + 5).Value = "RightFooter"
    
    ' ヘッダ情報を出力する行を初期化
    OutputRow = 2
    
    ' フォルダ選択ダイアログを表示
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    
    If dlg.Show = -1 Then ' ダイアログでOKが選択された場合
        ' 処理開始時刻を記録
        startTime = Timer
        
        FolderPath = dlg.SelectedItems(1) & "\"
        ' 再帰的にフォルダ内のエクセルファイルを処理
        RecursiveGetExcelFileInfo FolderPath, OutputRow
        Application.ScreenUpdating = True
        
        ' 処理終了時刻を記録
        endTime = Timer
        
        ' 処理時間を計算
        elapsedTime = endTime - startTime
        
        Cells(OutputRow + 1, 1).Value = "[INFO] 処理が完了しました。 処理時間: " & Format(elapsedTime, "0.00") & " 秒"
        Debug.Print "処理が完了しました。 処理時間: " & Format(elapsedTime, "0.00") & " 秒"
        MsgBox "処理が完了しました。 処理時間: " & Format(elapsedTime, "0.00") & " 秒"
    
    Else
        Exit Sub ' キャンセルされた場合は終了
    End If
End Sub