【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

以上