複数シートのデータを一つのシートにまとめる(VBA):エクセル練習問題

問題1(列方向へコピー)　　　　topへ

実験データを各シートに保管しています。
各シートのデータを一つにまとめる必要があるのですが、コピー&ペーストでは手間がかかるので、マクロ(VBA)で処理したいと思います。

データのある各シートは下図のように行や列が異なっているものです。

シート「data1」～「data5」のようす

「data4」は項目だけが入力されていて、データがないシートです。
データの貼り付けではこのシートは無視します。

シート「data1」	シート「data2」

シート「data3」	シート「data4」

シート「data5」

データをまとめたシート「全データ」のようす
「data1」～「data5」を一つのシート「全データ」にまとめた結果です。
ただし、項目だけのシート(ここではシート「data4」)は無視しています。

解答例1　　　　topへ

まとめるシート「全データ」は先頭に持ってきます。
まず、「全データ」シートが有るのか/無いのかを調べて、無いときは「全データ」シートを先頭に作成します。
「全データ」シートがすでにある場合は、データをクリアします。

シート名「全データ」はメインのコードで変数のnewShで指定するようにしています。

Sub sh_check5(ByVal newSh As String)
　　Dim Sh As Worksheet, myFlag As Boolean
　　
　　myFlag = False
　　For Each Sh In ThisWorkbook.Worksheets
　　　　If Sh.Name = newSh Then
　　　　　　myFlag = True
　　　　　　'----全データシートのデータをクリアし、先頭へ移動します
　　　　　　Worksheets(newSh).Cells.Clear
　　　　　　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 matome5()
　　Dim Sh
　　Dim newSh As String
　　Dim i As Integer
　　Dim lRow As Long, lCol As Long, lRow2 As Long
　　Dim lCol2 As Long

　　Application.ScreenUpdating = False
　　'----まとめ用のシートの有無をチェックします
　　newSh = "全データ"
　　sh_check5 (newSh)

　　'----まとめ用のシートへデータをコピーします
　　For i = 2 To Worksheets.Count
　　　　With Worksheets(i)
　　　　　　lRow = .Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　lCol = .Cells(10, Columns.Count).End(xlToLeft).Column
　　　　　　If lRow >= 2 Then
　　　　　　　　lCol2 = Worksheets(1).Cells(10, 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

調べるデータシートはシート見出しの2つ目以降にあるので、For i = 2 To Worksheets.Count　とします。(先頭にはまとめ用のシートが有るので)
データシートの行の最終位置lRowは1列目の位置を調べます。
- lRow = .Cells(Rows.Count, 1).End(xlUp).Row
データシートの列の最終位置lCol はデータ部分の10行目の位置を調べます。
- lCol = .Cells(10, Columns.Count).End(xlToLeft).Column

貼り付け先（まとめ用のシートWorksheets(1))の最終位置を調べ、これに　+1　した位置が貼り付け先の列位置になります。

lCol2 = Worksheets(1).Cells(10, Columns.Count).End(xlToLeft).Column + 1

データがない状態の最終位置lCol2は2となるので、この時は貼り付け先は「1」とする必要があります。

If lCol2 = 2 Then lCol2 = 1
　　　.Activate
　　　.Range(Cells(1, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(1, lCol2)
End If

　　For i = 2 To Worksheets.Count
　　　　With Worksheets(i)
　　　　　　'データシートの最終行
　　　　　　lRow = .Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　'データシートの最終列
　　　　　　lCol = .Cells(10, Columns.Count).End(xlToLeft).Column
　　　　　　'まとめシートの最終列(貼り付け先)
　　　　　　If lRow >= 2 Then
　　　　　　　　lCol2 = Worksheets(1).Cells(10, 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

解答例2　　　　topへ

シート名「全データ」はメインのコードで変数のnewShで指定するようにしています。
このコードは上記（解答例１）のものと同じです。

コピーして貼り付けるコードは下表のようにしました。

最初のデータシートでは1行目のタイトル行もコピーしますが、2つ目以降は2行目以降のデータだけをコピーするようにしています。

Sub matome6()
　　Dim Sh
　　Dim newSh As String
　　Dim i As Integer
　　Dim lRow As Long, lCol As Long, lRow2 As Long
　　Dim lCol2 As Long

　　Application.ScreenUpdating = False
　　'----全データシートの有無をチェックします
　　newSh = "全データ"
　　sh_check5 (newSh)

　　'----データをコピーします
　　For i = 2 To Worksheets.Count
　　　　With Worksheets(i)
　　　　　　lRow = .Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　lCol = .Cells(10, Columns.Count).End(xlToLeft).Column
　　　　　　If lRow >= 2 Then
　　　　　　　　lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　　　　　If lRow2 = 2 Then
　　　　　　　　　　lRow2 = 1
　　　　　　　　　　.Activate
　　　　　　　　　　.Range(.Cells(1, 1), .Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
　　　　　　　　End If
　　　　　　　　.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

エクセル練習問題：複数シートのデータを一つのシートにまとめる(VBA)

問題1(列方向へコピー)　　　　topへ

解答例1　　　　topへ

問題2(行方向へコピー)　　　　topへ

解答例2　　　　topへ

スポンサードリンク

エクセル練習問題：複数シートのデータを一つのシートにまとめる(VBA)

問題1(列方向へコピー) topへ

解答例1 topへ

問題2(行方向へコピー) topへ

解答例2 topへ

問題1(列方向へコピー)　　　　topへ

解答例1　　　　topへ

問題2(行方向へコピー)　　　　topへ

解答例2　　　　topへ