エクセルのマクロで各Sheetのデータを複数コピー&ペーストしたいです

質問

エクセルのマクロで各Sheetのデータを複数コピー&ペーストしたいです
１つのエクセルファイルの中に複数のSheetがあります。
各Sheetの4行目以降（5行目から）にデータのあるA列～O列をコピーしていって、
挿入-ワークシート（Sheet1という名前で構わない）に全てを順番にコピーしていきたいです。
”新しいマクロの記録”で下記のように作成したのですが、
　・5行目からデータのあるA列～O列をコピーしていく　
　・存在する全てのSheetから上記の作業をする
というマクロの書き方が分かりません。
恐れ入りますがお時間ある方で上記の内容をご理解頂ける方がいましたらアドバイス頂ければ非常に助かります。

Sub Macro1()
Sheets.Add
Sheets("ER10(zy)").Select
Rows("5:8").Select
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
Sheets("ER10(cx)").Select
Rows("5:9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("A5").Select
ActiveSheet.Paste
Sheets("ER10(zht)").Select
Rows("5:13").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("A10").Select
ActiveSheet.Paste
End Sub

回答No.2

Wendy02 · ベストアンサー

#このようにシートごとに、行数が任意で変わる場合は、何か条件が必要です。
#5行目から、8行目しかないデータがないとか、また、「合計」という文字が、8行目にあるとか、何らかの理由が必要です。

このぐらいの質問を、言葉で答えてもよいかと思います。他人のマクロ・コードを読んで直せというのはマナーにも関わります。いくらネットにあったものでも、そのマクロは見本としては及第点は取れてはいても、見本とすべきレベルには達していません。

>　.Activate
>　.Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
エラーでなくても、ここがうまくありません。
ネット上の半分ぐらいのコードは、不備なものが多いです。それは、Microsoft サポートでも、プロとは思えないような素人の内容も出てきます。

適切なお答えが得られませんでしたので、こちらが考えたものでコードを提示させていただきます。
'5行目15列までコピーするようにできています。

Sub Test1()
　Dim sh As Worksheet
　Dim newSh As Variant
　Dim i As Long, j As Long
　Set newSh = Worksheets.Add
　Application.ScreenUpdating = False
　For Each sh In Worksheets
　　If sh.Name Like "ER*" Then
　　　j = sh.Cells(Rows.Count, 1).End(xlUp).Row - 4
　　　If j > 0 Then
　　　　If i = 0 Then
　　　　　sh.Rows(5).Resize(j, 15).Copy newSh.Cells(1, 1)
　　　　Else
　　　　　sh.Rows(5).Resize(j, 15).Copy newSh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　　　End If
　　　　i = i + 1
　　　End If
　　End If
　Next
　Application.ScreenUpdating = True
　Set newSh = Nothing
End Sub

お礼

早速の返信ありがとうございます！
試してみましたがSheetを５つ分しか読み込みません。
なので、Sheet５つ分（左のSheetから右へ５つ分）を読み込んでSheet1にコピーをしてくれますが、ほかのSheetはコピーしていません。
やりたいことは基本的にほぼそのとおり動いてくれているのですが、Sheetがあるだけ（２０Sheetくらいありますが数量は毎回不確定です）コピーするにはどのようにすればいいでしょうか？
大変恐れ入りますがアドバイスいただければ助かります。

回答No.1

Wendy02

Office カテゴリですでに同じ質問があるのですが、私は、Office系の回答を主としていますので、こちらに回答を付けさせていただきます。

残念ですが、この質問だけでは、回答ができません。いくらネット検索しても、そのコードではできません。

シート"ER10(zy)"　Rows("5:8")
シート"ER10(cx)"　Rows("5:9")
シート"ER10(zht)"　Rows("5:13")

このようにシートごとに、行数が任意で変わる場合は、何か条件が必要です。
5行目から、8行目しかないデータがないとか、また、「合計」という文字が、8行目にあるとか、何らかの範囲を限定する情報が必要です。目で見て人間が判断するように、プログラムで判定しなければなりません。

お礼

早速の返信本当にありがとうございます。
以下のマクロを使った場合にA列しかコピーしません。
これをA列～O列までをコピーするという指示を出したい場合どのようにすればいいでしょうか？

Sub matome()
　Dim i As Integer
　Dim lRow As Long, lCol As Long, lRow2 As Long
　　Application.ScreenUpdating = False
　 　'----全データシートの有無をチェックします

　　'----列見出しをコピーします
　　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