【VBA】指定フォルダ配下のブックを操作するためのマクロテンプレート

日本のSEはExcelがだぁ～いすき！
だから、なんでもかんでもExcelを使うよ。

そんなとき便利なのが、指定フォルダ配下のブックを操作するVBAマクロ。

例えば、「データの集計」や「ヘッダ・フッタ・更新履歴の修正」などなど。

毎回そんなマクロ組んでいたら1日が終わってしまう。
Office2003までの「FileSearch」は何かと便利だった。
しかし、Office2007以降の「FileSystemObject」は何かと厄介。

詳しくは、以下のエントリーを参照してほしい。

参考
【VBA】FileSearchの代わりにFileSystemObjectを使用する
【VBA】FileSystemObjectでファイル名（拡張子）の指定＋ソートして取得する

ということで、そんなときに使えるVBAマクロのテンプレートを紹介する。

指定フォルダ配下のブックを操作する

メイン処理は以下の通り。
ブックのみの操作の場合は、44行目にロジックを追加する。
シートの操作をする場合は、48行目にロジックを追加する。

Option Explicit '---------------------------------------------------------------- ' メイン処理 '---------------------------------------------------------------- Sub Main() '-- 高速化・チラツキ防止 Application.EnableEvents = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '-- 指定フォルダ配下のファイルリストを取得 Dim fileList As Collection '-- フォルダパスとファイルの拡張子（""で全てのファイルが対象）を指定 Set fileList = GetBookPaths("C:\作業フォルダ", "xlsx") '-- fileListのソート（必要に応じて） Set fileList = SortList(fileList, SortOrder.Asc) '-- ブックを開いてデータを読み込む Call ReadBooks(fileList) Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.EnableEvents = True End Sub '---------------------------------------------------------------- ' 【機能】ブックを開いてデータを読み込む ' 【引数】fileList: 対象ファイルのリスト ' 【戻値】なし '---------------------------------------------------------------- Sub ReadBooks(fileList As Collection) Dim filePath As Variant Dim ws As Worksheet Dim bookName As String '-- ブックの操作 For Each filePath In fileList Workbooks.Open Filename:=filePath bookName = ExtractNameFromPath(CStr(filePath)) 'TODO:ここにロジックを追加する '-- シートの操作 For Each ws In Workbooks(bookName).Worksheets 'TODO:ここにロジックを追加する Debug.Print bookName + ":" + ws.Name Next Workbooks(bookName).Close Next End Sub

モジュールは以下の通り。（クラスにした方が良かったかも）
VBEの「プロジェクトエクスプローラ」から「標準モジュール」を追加して、そのままコピペ。

Option Explicit '-- SortListに渡すオーダーを表す列挙体 Enum SortOrder Asc Desc End Enum '---------------------------------------------------------------- ' 【機能】指定されたpath配下のファイルの絶対パスを取得し、Collectionに入れて返す ' 【引数】path : 検索対象フォルダの絶対パス ' selectExt : 取得する拡張子 ' 【戻値】Collection: ファイルの絶対パス '---------------------------------------------------------------- Function GetBookPaths(path As String, selectExt As String) As Collection Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim fileList As New Collection '-- 指定フォルダのパスを取得し、再帰呼出によりサブディレクトリ内と検索する Dim folder As Variant Dim tmpFile As Variant For Each folder In fso.GetFolder(path).SubFolders '--　サブフォルダ内のファイルリストを設定する 'HACK: もうちょっとなんとかならんかね？ For Each tmpFile In GetBookPaths(folder.path, selectExt) fileList.Add Item:=tmpFile Next Next '-- ファイルパスを取得する Dim file As Variant For Each file In fso.GetFolder(path).Files If Not IsEmpty(selectExt) Or LCase(fso.GetExtensionName(file.path)) = selectExt Then '-- 指定された拡張子のみ、ファイルリストに加える fileList.Add file.path End If Next Set GetBookPaths = fileList End Function '---------------------------------------------------------------- ' 【機能】listをorder通りに並び替えて返す ' 【引数】list : ソートしたいリスト ' order : リストの並び順（SortOrderのAsc/Desc） ' 【戻値】Collection: ソートしたリスト '---------------------------------------------------------------- Function SortList(list As Collection, order As SortOrder) As Collection Dim ado As Object Set ado = CreateObject("ADODB.Recordset") '-- FILENAMEという名前でフィールドを作成 ado.Fields.Append "FILENAME", 200, 300, 32 ado.Open '-- 受け取ったlistをadoに登録する Dim path As Variant For Each path In list ado.AddNew ado.Fields(0) = path ado.Update Next '-- 指定されたorderによりソートを行う Select Case order Case SortOrder.Asc ado.Sort = "FILENAME ASC" Case SortOrder.Desc ado.Sort = "FILENAME DESC" End Select '-- ソートされたado.Filedsを戻り値sortedListに設定する Dim sortedList As Collection Set sortedList = New Collection ado.MoveFirst Do Until ado.EOF '-- CStrで文字列型にしないとRecordsetが格納されてしまう sortedList.Add CStr(ado.Fields(0)) ado.MoveNext Loop ado.Close Set ado = Nothing Set SortList = sortedList End Function '---------------------------------------------------------------- ' 【機能】絶対パスからファイル名を抽出する ' 【引数】path  : ファイル名を抽出したいパス ' 【戻値】String: ファイル名 '---------------------------------------------------------------- Function ExtractNameFromPath(path As String) As String '-- 絶対パスからファイル名直前の"\"の位置を取得 Dim pos As Integer pos = InStrRev(path, "\") + 1 ExtractNameFromPath = Mid(path, pos) End Function

以上