仕事で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の文法まとめ