仕事でExcelを使っていると、ある分割単位(例えば都道府県とか)でファイルを分けて情報を管理することがよくあります。このようにファイルを複数に分割していると、フィルタ機能が使えない為にファイル間での記載方法がブレてしまいがちです。
これから紹介するマクロは、複数に分割した特定フォーマットのファイルの内容を1つのシートに集約し、フィルタをかけられるようにすることを目的としています。

実行画面のイメージ

マクロを登録したファイルの「INPUT」シートを実行画面とします。
「収集対象のフォルダのパス」というタイトルのついているオレンジで網掛けされたセルに集約したいファイルが格納されているフォルダのパスを入力します。
「実行」と記載されたボタンには、Startというマクロを登録しています。

実行結果の出力画面のイメージ

マクロを登録したファイルの「OUTPUT」シートを出力画面とします。
収集対象のシートのフォーマットに合わせて、列1～列5を用意しています。

収集対象のファイルのイメージ

ここでは話を簡単にするために、収集対象のシート名は一律「TARGET」とします。

VBAによる情報の集約処理

マクロを登録したファイルの「INPUT」シートの「実行」ボタンに、Startという名前のマクロを登録します。ボタン押下後は指定したフォルダ配下のファイル名をサブフォルダ配下も含めて検索し、そのファイルのTARGETシートに記載されている内容を1行ずつOUTPUTシートに出力していきます。


' 定数とグローバル変数
Private Const INPUT_SHEET_NAME = "INPUT"
Private Const OUTPUT_SHEET_NAME = "OUTPUT"
Private Const TARGET_SHEET_NAME = "TARGET"
Private TARGET_FOLDER_PATH As String

' マクロの開始
'
' 引数　 : なし
' 返り値 : なし
Sub Start()

    ' INPUTシートに入力されている値をグローバル変数に代入する。
    TARGET_FOLDER_PATH = Worksheets(INPUT_SHEET_NAME).Cells(8, 2).Text

    Dim outputSheetIndex As Long: outputSheetIndex = 2
    Call GetFileDataRecursively(TARGET_FOLDER_PATH, outputSheetIndex)
    
    MsgBox ("終わりました")

End Sub


' 指定したフォルダ直下のファイル名を取得し、そのファイルの入力情報を取得する処理を実行する
'
' 引数　 : folderPath 対象フォルダのパス
' 　　   : outputSheetIndex "OUTPUT"シートの行番号
' 返り値 : なし
Function GetFileDataRecursively(ByVal folderPath As String, ByVal outputSheetIndex As Long)

    Dim fileName As String
    Dim subFolder As Object

    fileName = Dir(folderPath & "\*.*")

    Do While fileName <> ""
    
        outputSheetIndex = GetFileData(folderPath & "\" & fileName, outputSheetIndex)

        fileName = Dir()

    Loop

    With CreateObject("Scripting.FileSystemObject")

    ' サブフォルダを取得し、その数だけ再帰的に処理を実行する
    For Each subFolder In .GetFolder(folderPath).SubFolders
        Call GetFileDataRecursively(subFolder.Path, outputSheetIndex)
        Next subFolder
    End With

End Function


' ファイルのデータを1行ずつ読み込み、"OUTPUT"シートに出力する
'
' 引数　 : filePath 対象ファイルのパス
' 　　   : outputSheetIndex "OUTPUT"シートの行番号
' 返り値 : "OUTPUT"シートの行番号
Function GetFileData(ByVal filePath As String, ByVal outputSheetIndex As Long) As Long

    Workbooks.Open (filePath)
        
    Dim result As Boolean: result = True

    Dim row As collection
    Dim count As Long: count = 2

    Do While result = True

        Set row = GetRow(count)
        result = IsValid(row)
            
        ' 取得した行のいずれかのセルに入力がある場合、"OUTPUT"シートに出力する
        If result = True Then
            
            Workbooks(ThisWorkbook.Name).Worksheets(OUTPUT_SHEET_NAME).Cells(outputSheetIndex, 1) = row("列1")
            Workbooks(ThisWorkbook.Name).Worksheets(OUTPUT_SHEET_NAME).Cells(outputSheetIndex, 2) = row("列2")
            Workbooks(ThisWorkbook.Name).Worksheets(OUTPUT_SHEET_NAME).Cells(outputSheetIndex, 3) = row("列3")
            Workbooks(ThisWorkbook.Name).Worksheets(OUTPUT_SHEET_NAME).Cells(outputSheetIndex, 4) = row("列4")
            Workbooks(ThisWorkbook.Name).Worksheets(OUTPUT_SHEET_NAME).Cells(outputSheetIndex, 5) = row("列5")
            
            count = count + 1
            outputSheetIndex = outputSheetIndex + 1
            
        End If

    Loop
        
    Workbooks(ActiveWorkbook.Name).Close SaveChanges:=False

    GetFileData = outputSheetIndex

End Function


' 指定した行番号のデータを取得する
'
' 引数　 : index 行番号
' 返り値 : 1行分のデータ
Function GetRow(ByVal index As Long) As collection

    Dim row As collection
    Set row = New collection
   
    With row
        .Add Key:="列1", Item:=Worksheets(TARGET_SHEET_NAME).Cells(index, 1).Text
        .Add Key:="列2", Item:=Worksheets(TARGET_SHEET_NAME).Cells(index, 2).Text
        .Add Key:="列3", Item:=Worksheets(TARGET_SHEET_NAME).Cells(index, 3).Text
        .Add Key:="列4", Item:=Worksheets(TARGET_SHEET_NAME).Cells(index, 4).Text
        .Add Key:="列5", Item:=Worksheets(TARGET_SHEET_NAME).Cells(index, 5).Text
    End With
        
    Set GetRow = row

End Function


' 引数に指定した1行分のデータに、空文字以外のデータが入力されているか判定する
'
' 引数　 : row 1行分のデータ
' 返り値 : rowに空文字以外の入力がある場合にTrueが返却される
Function IsValid(ByRef row As collection) As Boolean

    For Each cell In row

        If cell <> "" Then
        
            IsValid = True

            Exit Function

        End If

    Next cell
        
    IsValid = False
    
End Function

実行結果のイメージ

今回は、収集対象のファイルと同じものを3ファイル用意したフォルダを対象にマクロを実行しました。画面を見ると、3ファイル分のデータが出力されていることが分かります。

最後に

今回紹介したマクロは比較的単純な内容ですが、個人的にはかなり便利だと思っています。
また、このマクロの応用としてはアンケートの集計などにも使えると思います。
この手のマクロは対象ファイルが多くなるほど便利になっていくので、よろしければ使ってみてください。

参考資料

■VBAの基本的な書き方について知りたい場合は・・
[Excel VBAの文法まとめ]
(http://qiita.com/yasuaki9973/items/76307da43d734dc97c66)