Excel(エクセル) VBA入門：複数のシートのデータを1つのシートにまとめる

データを1シートにまとめる

• 【前提条件】
  • 複数シートのデータ(元データ)は同じ列見出しのものが同じように並んでいるものとします。
  • 1行目には列見出しがあり、まとめる(コピーする)データは2行目以降にあるとします。
  • データをまとめるシート名は「全データ」とします。
• 各シートの状態例(元データ)
  

  Sheet1	Sheet2
  Sheet3

• なお、各シートは下図のように並んでいます。
  

まとめ用のシート「全データ」の有無を調べる

• まとめ用のシート「全データ」の有無を調べ、「全データ」が無いときはシートの先頭に新しく追加します。
  すでにある場合はデータをすべてクリアし、先頭に移動します。
• 【コード例】

  • Sub sh_check() 　Dim newSh As String 　Dim Sh As Worksheet, myFlag As Boolean 　　newSh = "全データ" 　　myFlag = False 　　For Each Sh In ThisWorkbook.Worksheets 　　　　If Sh.Name = newSh Then 　　　　　　myFlag = True 　　　　　　'----全データシートのデータをクリアし、先頭へ移動します 　　　　　　Worksheets(newSh).Cells.ClearContents 　　　　　　Worksheets(newSh).Move before:=Sheets(1) 　　　　　　Exit For 　　　　End If 　　Next Sh 　　'----全データシートを先頭へ追加します 　　If myFlag = False Then 　　　　ActiveWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = newSh 　　End If End Sub

複数シートのデータを「全データ」シートへコピーする

• 元データがあるシートは「全データ」の右側にあるシートから順番にデータをコピーします。

  • Sub matome() 　Dim i As Integer 　Dim lRow As Long, lCol As Long, lRow2 As Long 　　Application.ScreenUpdating = False 　 　'----全データシートの有無をチェックします 　　sh_check 　　'----列見出しをコピーします 　　Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1") 　　For i = 2 To Worksheets.Count 　　　　With Worksheets(i) 　　　　　　lRow = .Cells(Rows.Count, 1).End(xlUp).Row 　　　　　　lCol = .Cells(1, Columns.Count).End(xlToLeft).Column 　　　　　　'----シートのデータが2行以上の場合にコピーします 　　　　　　If lRow >= 2 Then 　　　　　　　　lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 　　　　　　　　.Activate 　　　　　　　　.Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1) 　　　　　　End If 　　　　End With 　　Next i 　　Worksheets(1).Activate 　　Range("A1").Select 　　Application.ScreenUpdating = True End Sub

実行後の状態

• 実行後の状態例
  

  全データ

• シートの並び順は下図のようになります。
  

シートの並びが異なるとき

• 上のコードではシートを左から順番にコピーしていきましたが、任意の順番でコピーしたいときは?
• 配列Shにコピーする順番にシート名を入れてやり、その順に処理します。
  • 下図のようにシートが並んでいますが、Sheet1,Sheet2,Sheet3の順番でデータをコピーしたいと思います。
    
• 【コード例】

  • Sub matome2() 　Dim Sh 　Dim i As Integer 　Dim lRow As Long, lCol As Long, lRow2 As Long 　　Application.ScreenUpdating = False 　 '----全データシートの有無をチェックします 　　sh_check 　　'----列見出しをコピーします 　　Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1") 　　'----コピーする順番にシート名を配列Shに登録します 　　Sh = Array("Sheet1", "Sheet2", "Sheet3") 　　For i = LBound(Sh) To UBound(Sh) 　　　　With Worksheets(Sh(i)) 　　　　　　lRow = .Cells(Rows.Count, 1).End(xlUp).Row 　　　　　　lCol = .Cells(1, Columns.Count).End(xlToLeft).Column 　　　　　　If lRow >= 2 Then 　　　　　　　　lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 　　　　　　　　.Activate 　　　　　　　　.Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1) 　　　　　　End If 　　　　End With 　　Next i 　　Worksheets(1).Activate 　　Range("A1").Select 　　Application.ScreenUpdating = True End Sub

  • 実行後の状態
    

PageViewCounter
　
　Since2006/2/27