ずっと前に仕事でxlsやdocのfooterの内容を変えることがあった時に書いたVBAコード。
仕事としてではなく試しに家で書いたものなので公開しても問題ない…はず(・∀・)
まあ内容的に古いので今更有効活用出来る内容ではないけれども、
いつかまた何かの役に立つかもしれないのでエントリとして保存しておこう。
多分、こちらのエントリを参考にして再帰部分は書いた…ような。
VBA(2007もOK)で,ファイルの再帰検索をしよう
その他の部分は色々なVBA関連のサイトやヘルプ(リファレンス?)を
参考にしたような気がするけど、詳しくは覚えていない。
MsgBoxとかの部分はお試しで入れているだけなので本当は要らない。
対象となるパスはxls_test()の中で直書きして、そこにxlsファイル群を
ぶちこんでこれを実行すると「All Rights Reserved, Copyright © ~」
みたいなのが右下のfooterに追加されるはず。
rightfooterを他のfooterやheaderに代えれば任意の部分の値を変更出来る…はず。
このままで動くかもしれないけれども、このコード自体は実地で
試したものではないので修正が必要かも(ノ∀`)
doc_test()はWord用。確かこれで動いたような気がする…けど自信はないw
最新のOfficeのVBAはどうなってるんだろうか。
Option Explicit Function FileSearch2007(dir_path, target_extension) Dim found_files As Collection Set found_files = New Collection Call FileSearch2007_Repeat(dir_path, found_files, target_extension) Set FileSearch2007 = found_files End Function Private Sub FileSearch2007_Repeat(dir_path, found_files, target_extension) Dim fso As FileSystemObject Dim target_folder As Folder Dim sub_folder As Folder Dim objFile As File Set fso = New FileSystemObject Set target_folder = fso.GetFolder(dir_path) For Each sub_folder In target_folder.SubFolders Call FileSearch2007_Repeat(sub_folder.Path,found_files,target_extension) Next sub_folder For Each objFile In target_folder.Files With objFile If ((UCase)fso.GetExtensionName(.Path)) = target_extension) Then found_files.Add Item:=.Path End If End With Next objFile Set fso = Nothing End Sub Sub xls_test() Dim dir_path As String Dim target_extension As String Dim found_files As Collection Dim found_num As Integer //ここに対象のファイル群があるパスを指定 dir_path = "<ディレクトリパス>" 'ThisWorkbook.Path & "\test" target_extension = UCase("xls") Set found_files = FileSearch2007(dir_path, target_extension) found_num = found_files.Count If found_num = 0 Then MsgBox "not found" Else MsgBox found_num & " found" Dim i As Integer Dim bookpath As String Dim TargetBook As Workbook Dim eachsheet As Worksheet For i= 1 To found_num bookpath=found_files(i) If Len(bookpath) > 0 Then 'MsgBox bookpath Set TargetBook = Workbooks.Open(bookpath) 'Office2010の互換性チェックを無効にする。 Dim ret As Variant ret = Application.Version If Val(ret)=14 Then ActiveWorkbook.CheckCompatibility = False Else End If For Each eachsheet In TargetBook.Worksheets With eachsheet.PageSetup //ここでFooterやHeaderの値を修正 RightFooter = "All Rights Reserved, Copyright " & Chr(169) & "" End With Next eachsheet TargetBook.Save TargetBook.Close End If Next i MsgBox "xls modified" End If End Sub Sub doc_test() Dim dir_path As String Dim target_extension As String Dim found_files As Collection Dim found_num As Integer dir_path = "<ディレクトリパス>" 'ThisWorkbook.Path & "\test" target_extension = UCase("doc") Set found_files = FileSearch2007(dir_path, target_extension) found_num = found_files.Count If found_num = 0 Then MsgBox "not found" Else MsgBox found_num & " found" Dim i As Integer Dim docpath As String Dim eachsheet As Worksheet Dim objWord As Object Set objWord = CreateObject("Word.Application") For i = 1 To found_num docpath = found_files(i) If Len(docpath) > 0 Then 'MsgBox docpath With objWord .Documents. Open docpath .ActiveDocument.Section(1).Footers(1).Range.Text= "All Rights Reserved, Copyright " & Chr(169) & "" .ActiveDocument.Save .ActiveDocument.Close End with End if Next i MsgBox "doc modified" End If End Sub