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

エクセル練習問題:複数シートのデータを一つのシートにまとめる(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へ

実験データを各シートに保管しています。
ここでは、各シートのデータを行方向へまとめたいと思います。
データのある各シートは下図のように行数が異なっているものです。
- シート「data1」～「data5」のようす
  - 「data4」はデータがないシートです。
    データの貼り付けではこのシートは無視します。
  シート「data1」シート「data2」
  
  シート「data3」シート「data4」
  
  シート「data5」
- データをまとめたシート「全データ」のようす
  「data1」～「data5」を一つのシート「全データ」にまとめた結果です。
  ただし、データのないシート(ここではシート「data4」)は無視しています。

解答例2 topへ

まとめるシート「全データ」は先頭に持ってきます。
まず、「全データ」シートが有るのか/無いのかを調べて、無いときは「全データ」シートを先頭に作成します。
「全データ」シートがすでにある場合は、データをクリアします。
- シート名「全データ」はメインのコードで変数のnewShで指定するようにしています。
  このコードは上記(解答例1)のものと同じです。
  
  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
コピーして貼り付けるコードは下表のようにしました。
- 最初のデータシートでは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

スポンサードリンク
(追記) (追記ここまで)

(追記) (追記ここまで)

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

PageViewCounter
Counter
Since2006/2/27