みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

エクセルのマクロで各Sheetのデータを複数コピー&ペーストしたいです
1つのエクセルファイルの中に複数の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

投稿日時 - 2010-11-05 09:45:20

QNo.6298237

困ってます

質問者が選んだベストアンサー

#このようにシートごとに、行数が任意で変わる場合は、何か条件が必要です。
#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

投稿日時 - 2010-11-05 12:03:24

お礼

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

投稿日時 - 2010-11-05 12:19:25

ANo.2

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.1

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

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

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

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

投稿日時 - 2010-11-05 10:30:45

お礼

早速の返信本当にありがとうございます。
以下のマクロを使った場合に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

投稿日時 - 2010-11-05 11:07:20

あなたにオススメの質問