【VBA】【Excel】別フォルダの複数ファイルを一つのファイルに集約する

はじめに

こんにちは。VBA初心者です。
ここでは、VBAでフォルダ内の複数ファイルを一つのファイルに集約する方法について書き記します。

実はこれに近いコードというのはすでにネットにゴロゴロ転がっているのですが、
どうも僕が欲しい仕様とは異なる…。

そこで、僕と同じ境遇の方に向けての情報共有と、自分の学びの整理のためにまとめていきます。

目的

・大量のデータをVBAを用いて一つのエクセルシートに超効率良くまとめる。

前提

・VBA初心者向けの内容
・まとめたいファイルの中身は、全て同一形式とする。

活用シーン

・各月で分けていた売上情報をまとめたい
・支店別に分けているデータをまとめたい
・Excelで回答してもらったアンケート結果をまとめたい
…等々

※イメージ図。値は適当だけど許してね！ニュアンスが伝わればいいんだよ！

実際に書いてみる

方針

①コピーしたいフォルダからエクセルブックのファイル名を取得し、開く
②最終行（空白セルに到達するまで）を取得し、そこまでをコピー
③集約先ファイルでも最終行を取得し、それ以降に貼り付ける
④コピー元ファイルを閉じる
⑤,①～④を繰り返す
⑥フォルダ内の全てのファイルのコピペが終了
⑦空白行を削除するために、ここではB列の値を取得。空白行の特定。
⑧空白行をどんどん変数に代入していく
⑨空白行の入った変数をまるごと消去
⑩集約先ファイルを保存して終了

かなり噛み砕いて記すとこんな感じです。
これをコードに落としていきましょう。

集約マクロ.xlsm

Option Explicit
 Sub 集約マクロ()

'初期設定

 '変数の設定

  'コピー元ファイル
    Dim sFile As String

  'コピー元と集約用のエクセルブック
    Dim sWB As Workbook, dWB As Workbook

  '集約先、コピー元の最終行取得用
    Dim lR As Variant
    Dim lastRow As Variant
    Dim lastRowP As Variant
    Dim Row As Variant
    Dim Col As Variant

  'コピー元の空白行を削除する用
    Dim GYO As Long
    Dim KuhakuGyo As Range
    Dim r As Long

 'フォルダとファイルのパス設定   
  '集約したい対象のファイルが入っているフォルダのフルパスを設定
    Const SOURCE_DIR As String = "フォルダのフルパス"
  '集約先にしたいファイルのフルパス設定
    Const DEST_FILE As String = "集約マクロ.xlsm"

  '不要な画面描画の抑制とアラートの非表示
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

'処理開始
 'コピペ処理
  'パスで指定したフォルダ内にあるエクセルブックのファイル名を取得
    sFile = Dir(SOURCE_DIR & "*.xls")

  'フォルダ内にブックがなければ終了
    If sFile = "" Then Exit Sub

  '集約用ブックを作成
    Set dWB = ActiveWorkbook

    Do

  '集約先シート最終行取得
    dWB.Worksheets("集約先のタブの名前").Activate
    lastRow = ActiveSheet.Cells(1, "A").SpecialCells(xlLastCell).Row

  '集約先出力行セット
    lR = lastRow + 1

  'コピー元のブックを開く
    Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile)

  'コピー元シートの最終行、最終列取得
    sWB.Worksheets("データのあるタブの名前").Activate
    Row = sWB.Worksheets("データのあるタブの名前").Range("A5").SpecialCells(xlLastCell).Row
    Col = sWB.Worksheets("データのあるタブの名前").Range("A1").SpecialCells(xlLastCell).Column

  'コピー
   sWB.Worksheets("データのあるタブの名前").Activate
   sWB.Worksheets("データのあるタブの名前").Range(Cells(5, 1), Cells(Row, "T")).Copy

  '張り付ける
   dWB.Worksheets("集約先のタブの名前").Activate
   dWB.Worksheets("集約先のタブの名前").Range("A" & a).PasteSpecial Paste:=xlPasteAll

  'コピー元ファイルを閉じる
   sWB.Close

  '次のブックのファイル名を取得
   sFile = Dir()
   Loop While sFile <> ""

  '空白行の削除
   'A列を参照し、シートの最終行を取得する
    GYO = Cells(Rows.Count, 1).End(xlUp).Row

   '2行目から最終行まで、B列のセルをチェック
    With ActiveSheet
    For r = 2 To GYO

    'B列のセルが空白なら変数KuhakuGyoに追加
    If IsEmpty(Cells(r, 2).Value) Then

    '最初の空白行に出会ったら行全体を KuhakuGyo にセット
    If KuhakuGyo Is Nothing Then
    Set KuhakuGyo = .Rows(r).EntireRow

    '2件目からは順次 KuhakuGyo に追加していく
    Else
    Set KuhakuGyo = Union(KuhakuGyo, .Rows(r).EntireRow)
    End If

    End If

    Next r

    End With

    '空白行があれば一括で削除する
    If Not KuhakuGyo Is Nothing Then
    KuhakuGyo.Delete
    End If

    '集約用ブックを保存
    dWB.SaveAs Filename:=DEST_FILE

    '集約完了メッセージの表示
    MsgBox "集約が完了しました"

End Sub

終わりに

補足

・コピー元のRange（範囲）を指定する際にタイトル行とか特定列だけをコピーしたい場合は、その都度Rangeの値を変えれば良いです。

・集約先のファイルに値が何もない、真っ白なシートの場合、エラーが起きます。集約先には、事前にタイトル行等を設定しておいて、表を作成。その表に上手くはまるようにRangeを指定すれば良いと思います。

以上です！