作成者名一覧を作成するExcelマクロ

Sub 指定したフォルダの全Excelファイルの作成者名一覧を作成する()
　Dim f_dlg As FileDialog
　Dim fold_path As String
　Dim file_name As String
　Dim bk As Workbook
　Dim i As Long
　
　Set f_dlg = _
　　Application.FileDialog(msoFileDialogfolderPicker)
　If f_dlg.Show = 0 Then Exit Sub
　
　fold_path = f_dlg.SelectedItems(1)
　file_name = Dir(fold_path & "\*.xls*")　
　If file_name = "" Then
　　MsgBox "指定されたフォルダにはExcelファイルがありません。"
　　Exit Sub
　End If
　
　ThisWorkbook.Worksheets.Add Before:=Sheets(1)
　
　Range("A1").Value = "『" & fold_path & "』のExcelファイル作成者名一覧"
　Range("A3").Value = "ファイル名"
　Range("B3").Value = "作成者名"
　Range("A3:B3").HorizontalAlignment = xlCenter

　i = 4　' 作成者一覧を開始する行番号
　Do Until file_name = ""
　　Set bk = Workbooks.Open(Filename:=fold_path & "\" & file_name)
　　With ThisWorkbook.Sheets(1)
　　　.Cells(i, 1).Value = _
　　　　　bk.Name
　　　.Cells(i, 2).Value = _
　　　　　bk.BuiltinDocumentProperties("Author").Value
　　End With
　　bk.Close SaveChanges:=False
　　
　　file_name = Dir
　　i = i + 1　
　Loop
　
　Range("A3", Cells(i, 2)).Columns.AutoFit
End Sub