Excel VBA 複数のシートのデータを1つのシートにまとめる方法

VBAで複数のシートに同じ形式のデータがあるExcelファイルを、1つのシートにデータを行方向へまとめる方法から、最大行を超えた場合の処理方法をご説明します。

シートが年や各月で分かれている場合に、全データで集計したいときにどうしても1つのシートにまとめたくなることがあります。

そんな時のためのひな形を一つ用意しておくだけで、簡単に複数のシートに分かれているデータを1つのシートにまとめる事ができます。

もしExcelの最大行を超えるようなデータの場合は、エラーとなるため最大行を超える結合が発生した場合の対処法も記載したいと思います。

複数ファイルのデータをまとめる方法や、サブフォルダのすべてのファイルをまとめる方法については、下記記事をご覧ください。

1.複数シートのデータを1シートにまとめる方法
2.サンプルコード
- コードの説明
- 試しに最大行を超えるだけループしてみる

1.複数シートのデータを1シートにまとめる方法

複数のシートに同じ形式が存在する場合、1つのシートにまとめるためには次のような方法でまとめていきます。

まずはまとめるためのシートを作成します。

まとめるためのシートを作成したら、次はデータのあるシートのデータを格納します。

データを格納したらまとめるシートの最終行に貼り付けます。

これをシート数分繰り返すだけです。

注意点はExcelの最大行を超える連結を行おうとした場合、エラーとなります。

また、Excelはセルへの出力がとても遅いため、各シートのデータをすべて配列に格納してからまとめるシートへ出力しようとした場合も注意が必要です。

それはメモリー不足のエラーが発生する可能性です。

Excelの配列は無限に領域を確保できるわけではないため、いつかはメモリー不足になります。

そのため、よほど処理速度にこだわらない限りは1シートずつ格納と出力を行った方が良いです。

2.サンプルコード

さっそくサンプルコードです。

次のように1月～12月というシートがあり、それぞれに「日付」「価格」「販売個数」「売上」といったデータが日数分存在します。

これらのデータを1つのシートにまとめる処理を行います。

Option Explicit

Dim i       As Long
Dim r       As Long
Dim s       As Long
Dim Sh      As Worksheet
Dim MaxRow  As Long
Dim MaxCol  As Long
Dim MyArray As Variant
Dim JoinSh  As Worksheet
Dim n       As Long
Dim shcount As Long
Application.DisplayAlerts = False 'シート削除時のアラート停止

For Each Sh In Worksheets

    If InStr(Sh.Name, "統合") <> 0 Then Sh.Delete 'すでに統合シートが存在する場合は一旦削除

Next

Application.DisplayAlerts = True 'シート削除時のアラート停止を解除

shcount = Worksheets.Count

s = 1 '最大行を超えた場合次の統合シートを作成するための番号

Worksheets.Add after:=Worksheets(shcount) '新規に統合シートを追加
ActiveSheet.Name = "統合"

Set JoinSh = ActiveSheet '統合シートを変数に格納

For i = 1 To shcount 'シートを統合シートの次～末尾までループ

    With Worksheets(i) '各月シート
        Debug.Print .Name
    
        If i = 2 Then
        
            r = 1 '最初だけ項目も取得
        
        Else
        
            r = 2 '最初以外は2行目から取得
        
        End If
    
        MaxRow = .Cells(Rows.Count, 1).End(xlUp).Row '1列目で最終行を取得
        MaxCol = .Cells(1, Columns.Count).End(xlToLeft).Column '1行目で最終列を取得
        
        MyArray = Range(.Cells(r, 1), .Cells(MaxRow, MaxCol)) 'A1～データ末尾まで配列に格納
    
    End With
    
    With JoinSh '統合シート
        
        MaxRow = .Cells(Rows.Count, 1).End(xlUp).Row '統合シートの１列目で最終行取得
        
        If MaxRow + UBound(MyArray) > Rows.Count Then '最大行を超える場合の処理
            s = s + 1 '統合シートの番号を加算
        
            Worksheets.Add after:=Worksheets(Worksheets.Count) '新規に統合シートを追加
            ActiveSheet.Name = "統合" & s '名前が同じにならないように番号を追加
            
            Set JoinSh = ActiveSheet '統合シートを変数に格納
            MaxRow = JoinSh.Cells(Rows.Count, 1).End(xlUp).Row '統合シートの１列目で最終行取得
            
        End If
        
        If JoinSh.Cells(1, 1) = "" Then
            '最初だけ1行目から貼り付け
            Range(JoinSh.Cells(1, 1), JoinSh.Cells(UBound(MyArray), MaxCol)) = MyArray
        
        Else
            '最初以外は最終行の次に貼り付け
            Range(JoinSh.Cells(MaxRow + 1, 1), JoinSh.Cells(MaxRow + UBound(MyArray), MaxCol)) = MyArray
        
        End If
        
    End With

Next i

End Sub