Excel VBA の備忘録　～複数ファイルからの１ファイルへのまとめ～

今回は複数ファイルを取り扱うVBAを記載してみました。

機能
処理機能
実装
追加が必要な機能

機能

拠点ごとに従業員の情報が入ったExcelファイルが用意されています。各拠点のフォーマットは一致しているものの、複数シートに分かれていて整理しにくい構造になっていると仮定します。

そこで、これらのファイルを一つのシートに結合してDB化し、その後の情報を取り出しやすいようにするのが目的です。

学習のためVBAの基礎となる部分のみの記載となっておりますのでご了承ください。

処理機能

各拠点のデータが以下のようなフォーマットで入っている前提です。

情報１：従業員番号横方向にも、縦方向にも並んでいます。

情報２：こちらの方は縦方向のみです。

この形式のファイルが拠点数あり、最終的には従業員No.毎にすべてのデータを１行に収めたいと思います。

実装

各シートは以下のような機能となります。

実行	マクロを実行するボタンを配置
ファイル	集計を行いたいファイル名をシートに反映
情報１	処理機能で説明した拠点ごとのファイルのシート「情報１」のコピーシート
情報２	処理機能で説明した拠点ごとのファイルのシート「情報２」のコピーシート
個別集計	各拠点の集計を実施
全集計	各拠点の集計を足していく形で集計表を作成

今回も少し工夫した点から記述したいと思います。

各拠点のファイルはコマンドプロンプトを用いればすぐにできるかとも思いましたが、自分の勉強の意味も込めて作成しました。

特段難しいところはないようですが、Dirの使い方が少し特殊で、読み出すごとに次のファイル名をリターン値として返し、最後は””になるとのこと。実行するとシートの「ファイル」に一覧が生成されます。

Sub ファイル名取得()
    Dim DataFilePath As String
    Dim buf As String
    Dim i As Long
    
    DataFilePath = ThisWorkbook.Path & "/data/"
    buf = Dir(DataFilePath & "*.xlsx")
    i = 2 '2行目から記載
    Do While buf <> ""
        ThisWorkbook.Worksheets("ファイル").Cells(i, 1) = buf
        buf = Dir()
        i = i + 1
    Loop
End Sub

Sub ファイル名取得()

Dim DataFilePath As String

Dim buf As String

Dim i As Long

DataFilePath = ThisWorkbook.Path & "/data/"

buf = Dir(DataFilePath & "*.xlsx")

i = 2 '2行目から記載

Do While buf <> ""

ThisWorkbook.Worksheets("ファイル").Cells(i, 1) = buf

buf = Dir()

i = i + 1

Loop

End Sub

次がメインの集計を行うマクロとなります。Callしている”情報コピー”のマクロは各ファイルのシート「情報１」「情報２」をマクロ実行の同じ名前のシートにコピーしており、その結果がシート「個別集計」に反映されるので、その結果をシート「全集計」にコピーするようになっています。

Sub 集計()
    Dim DataFilePath As String
    Dim FileName As String
    Dim FileSheet As Object
    Dim KobetuSheet As Object
    Dim ZenSheet As Object
    Dim i As Long
    Dim j As Long
    
    DataFilePath = ThisWorkbook.Path & "/data/"
    Set FileSheet = ThisWorkbook.Worksheets("ファイル")
    Set KobetuSheet = ThisWorkbook.Worksheets("個別集計")
    Set ZenSheet = ThisWorkbook.Worksheets("全集計")
    
    i = 2 'ファイル名、シート「ファイル」２行目から順次取得
    j = 2 'シート「個別集計」から「全集計」へコピーする際、２行目から開始
    
    Do While FileSheet.Cells(i, 1) <> ""
        FileName = FileSheet.Cells(i, 1)
        Call 情報コピー(DataFilePath & FileName)  'ファイルを開いてこのファイルに情報をコピー
        ZenSheet.Range(Cells(j, 1), Cells(j + 9, 9)).Value = KobetuSheet.Range("A3:I12").Value
        i = i + 1
        j = j + 10 '10行ずらす
    Loop
End Sub

Sub 集計()

Dim DataFilePath As String

Dim FileName As String

Dim FileSheet As Object

Dim KobetuSheet As Object

Dim ZenSheet As Object

Dim i As Long

Dim j As Long

DataFilePath = ThisWorkbook.Path & "/data/"

Set FileSheet = ThisWorkbook.Worksheets("ファイル")

Set KobetuSheet = ThisWorkbook.Worksheets("個別集計")

Set ZenSheet = ThisWorkbook.Worksheets("全集計")

i = 2 'ファイル名、シート「ファイル」２行目から順次取得

j = 2 'シート「個別集計」から「全集計」へコピーする際、２行目から開始

Do While FileSheet.Cells(i, 1) <> ""

FileName = FileSheet.Cells(i, 1)

Call 情報コピー(DataFilePath & FileName) 'ファイルを開いてこのファイルに情報をコピー

ZenSheet.Range(Cells(j, 1), Cells(j + 9, 9)).Value = KobetuSheet.Range("A3:I12").Value

i = i + 1

j = j + 10 '10行ずらす

Loop

End Sub

元のExcelのフォーマットが処理にややいびつですが、一旦成型したシート（ここでは「個別集計」）を作成することにより対応しています。結果マクロはとても短くできています。

追加が必要な機能

実際に使用するには以下のような追加機能が必要かと思います。

「情報１」あるいは「情報２」に空白があった場合の処理（DLいただければ、マクロには空白行削除の処理も入れているものがみられますが、これだけでは不十分となっております。）
「情報１」あるいは「情報２」にしかないNo.があった場合の処理（例えば”「情報１」には必ずNo.があるはずなので、「情報２」にしかない場合はエラーとする”など、前提条件を決めておく必要があるとおもいます。）

ソースはこちら→データまとめ

ZIPファイルなので、素直にUPできました、、、。