作成者名を一括変更するExcelマクロ

Sub 指定したフォルダの全Excelファイルの作成者名を変更する()

　Const AUTHOR_NEW = "山田太郎"

　Dim f_dlg As FileDialog
　Dim fold_path As String
　Dim file_name As String
　Dim bk As Workbook
　Dim msg As String
　
　''フォルダ指定用ダイアログの表示
　Set f_dlg = _
　Application.FileDialog(msoFileDialogFolderPicker)
　If f_dlg.Show = 0 Then Exit Sub
　
　''フォルダのフルパスを変数に格納
　fold_path = f_dlg.SelectedItems(1)
　
　''指定されたフォルダでExcelファイルを探す
　file_name = Dir(fold_path & "\*.xls*")
　
　If file_name = "" Then
　　msg = "フォルダ『" & fold_path & "』にはExcelファイルがありません。"
　　MsgBox msg
　　Exit Sub
　End If
　
　msg = "フォルダ『" & fold_path & "』内の全Excelファイルの作成者名を『" & AUTHOR_NEW & "』に変更していいですか？"
　If MsgBox(msg, vbYesNo) = vbNo Then
　　msg = "処理を中止します。"
　　MsgBox msg
　　Exit Sub
　End If
　
　Application.ScreenUpdating = False
　Application.EnableEvents = False
　
　''指定されたフォルダの全Excelファイルにループ処理
　Do Until file_name = ""
　
　　''ブックを開く
　　Set bk = Workbooks.Open(Filename:=fold_path & "\" & file_name)
　　
　　''作成者名を変更する
　　bk.BuiltinDocumentProperties("Author").Value = AUTHOR_NEW
　　
　　''開いたブックを保存して閉じる
　　bk.Close SaveChanges:=True
　　
　　''次に開くブックのファイル名を取得
　　file_name = Dir
　　
　Loop
　
　Application.EnableEvents = True
　Application.ScreenUpdating = True

　msg = "フォルダ『" & fold_path & "』内の全Excelファイルの作成者名を『" & AUTHOR_NEW & "』に変更しました。"
　MsgBox msg