1. Home » 
2. Excel講座の総目次 » 
3. Excel VBA入門：目次 » 
4. 複数のシートのデータを1つのシートにまとめる

複数のシートのデータを1つのシートにまとめる:Excel VBA入門

• 複数シートのデータを一つのシートにまとめる例です。
  行方向へデータを追加するようにコピー&貼り付けしています。また列方向への例も追記しました。

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

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

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

• まとめ用のシート「全データ」の有無を調べ、「全データ」が無いときはシートの先頭に新しく追加します。
  すでにある場合はデータをすべてクリアし、シート見出しの先頭に移動します。
• このコードは以降の各コードから実行しますので、標準モジュールに記載する必要があります。
• 【コード例】
  

  Sub sh_check() 　Dim newSh As String 　Dim Sh As Worksheet, myFlag As Boolean 　　newSh = "全データ"　'---まとめ用のシート名です 　　myFlag = False　'---まとめ用のシートが有ったら True /無かったら 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

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

• 元データがあるシートは「全データ」の右側にあるシートから順番にデータをコピーします。
  このコード内から　sh_check　を実行していますので、　上記の　sh_checkのコード　も記載する必要があります。
  

  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

• セルをそのままコピーしていますので、数式などを含む場合には不都合があるかもしれません。
  貼り付け時に値の貼り付けを行う場合は
  Range(Cells(2, 1), Cells(lRow, lCol)).Copy　Worksheets(1).Cells(lRow2, 1)
  ↓
  値の貼り付けに書き換えればいかがでしょう?
  Range(Cells(2, 1), Cells(lRow, lCol)).Copy
  Worksheets(1).Cells(lRow2, 1).PasteSpecial xlPasteValues
  に修正してください。(2020/6/24に追記しました)

実行後の状態

• 実行後の状態例
  全データ
  
• シートの並び順は下図のようになります。
  

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

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

  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

• セルをそのままコピーしていますので、数式などを含む場合には不都合があるかもしれません。
  貼り付け時に値の貼り付けを行う場合は
  Range(Cells(2, 1), Cells(lRow, lCol)).Copy　Worksheets(1).Cells(lRow2, 1)
  ↓
  値の貼り付けに書き換えればいかがでしょう?
  Range(Cells(2, 1), Cells(lRow, lCol)).Copy
  Worksheets(1).Cells(lRow2, 1).PasteSpecial xlPasteValues
  に修正してください。(2020/6/24に追記しました)
• 実行後の状態
  

列方向へコピーしてまとめたい？　　　　topへ

• 上記は「全データ」シートへ行方向へコピーしましたが、列方向へコピーする例です。
  上記の　matome2　を修正しています。
• 【コード例】
  matome2　との主な違いは赤字の部分です。
  このコード内から　sh_check　を実行していますので、　上記の　sh_checkのコード　も記載する必要があります。
  

  Sub matome3() 　Dim Sh 　Dim i As Integer 　Dim lRow As Long, lCol As Long, lRow2 As Long 　Dim lCol2 As Long 　　Application.ScreenUpdating = False 　　'----全データシートの有無をチェックします 　　sh_check 　　'----コピーする順番にシート名を配列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 　　　　　　　　lCol2 = Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column + 1 　　　　　　　　If lCol2 = 2 Then lCol2 = 1 　　　　　　　　.Activate 　　　　　　　　.Range(Cells(1, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(1, lCol2) 　　　　　　End If 　　　　End With 　　Next i 　　Worksheets(1).Activate 　　Range("A1").Select 　　Application.ScreenUpdating = True End Sub

• 実行後の状態(データが元のものと異なっていますが、列方向へコピーされているのが分かると思います)
  

スポンサードリンク

PageViewCounter
　
　Since2006/2/27