マクロでシート２～６のデータをシート１に転記したい

マクロでシート２～６のデータをシート１に転記したいです。
シート２～６のデータを
シート１に順番に転記したくてマクロの記録を利用して作成しました。
シート２～６は列は同じですが行数は異なります。
また行数は作業の都度異なります。
同じ記述が繰り返されているので
もう少し記述が短くできるのではと思うのですが
どうすればいいでしょうか？

Sub データ更新()
'シート１の前回データをクリア
Sheets("シート１").Select
Range("A2:Q2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents

Range("A2").Select
Sheets("シート１").Select
Range("A1").Select

Sheets("シート２").Select
Range("A1").Select 'ヘッダーも合わせて取得
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("シート１").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.End(xlDown).Select
Selection.Offset(1, 0).Select

Sheets("シート３").Select
Range("A2").Select 'データのみ取得
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("シート１").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.End(xlDown).Select
Selection.Offset(1, 0).Select

Sheets("シート４").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("シート１").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.End(xlDown).Select
Selection.Offset(1, 0).Select

Sheets("シート５").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("シート１").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.End(xlDown).Select
Selection.Offset(1, 0).Select

Sheets("シート６").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("シート１").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.End(xlDown).Select
Selection.Offset(1, 0).Select

End Sub

No.5 ベストアンサー 回答者： mitarashi 回答日時： 2010/11/19 21:30

#1,3です。

誤解しておりましたが、シート１のA1から貼り付けて良いのですね。
どこをいじれば良いか、質問者様ならお分かりになると思いますが、
シート１をまっさらにして良いのなら、冗長なところを除いて下記でいけると思います。
Sub データ更新()
Dim sh As Worksheet
Dim destRange As Range, srcRange As Range

With Sheets("シート１")
.Cells.Clear
Set destRange = .Cells(1)
End With
For Each sh In ActiveWorkbook.Worksheets
Select Case sh.Name
Case "シート２"
Set srcRange = sh.Range("A1").CurrentRegion
srcRange.Copy destRange
Set destRange = destRange.End(xlDown).Offset(1, 0)
Case "シート３", "シート４", "シート５", "シート６"
Set srcRange = sh.Range("A1").CurrentRegion
Set srcRange = Intersect(srcRange, srcRange.Offset(1, 0))
srcRange.Copy destRange
Set destRange = destRange.End(xlDown).Offset(1, 0)
Case Else
'何もしない
End Select
Next sh
End Sub

この回答へのお礼

何度も何度もすいませんでした。
説明が悪くてすいませんでした。

＞シート１のA1から貼り付けて良いのですね。

はいそうです。
1行目は項目行なんです。
ですからシート１は一旦全部クリアしてまっさらにして
シート２は全行を
シート1の１行目から貼付。
これで1行目がまた項目行になります。
でシート３～６はもう項目行は不要なので
２行目～最終行を
貼り付けていきます。

今回の記述で思ったとおりに動きました。

またシート名を変更して他にも流用が可能です。
どうもありがとうございました。

お礼日時：2010/11/22 16:45

No.4 回答者： mu2011 回答日時： 2010/11/19 09:58

NO2です。

>シート２をみかんに変更するだけで動くのでしょうか？
　⇒シート名を拠り所にしているので動きません。
　　前提として、シート構成が左から「シート１」→「みかん」～「パイン」（この部分は任意）→「その他シート」順ならば以下のコードで可能です。


Sub シート結合()
Application.ScreenUpdating = False
Sheets(1).Cells.Clear
Sheets(2).Range("1:1").Copy Sheets(1).Range("A1")
For i = 2 To 6
With Sheets(i)
最終行 = .Cells(Rows.Count, 1).End(xlUp).Row
最終列 = .Cells(1, Columns.Count).End(xlToLeft).Column
If 最終行 >= 2 Then
開始行 = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
.Activate
.Range(Cells(2, 1), Cells(最終行, 最終列)).Copy _
Sheets("シート１").Cells(開始行, 1)
End If
End With
Next
Sheets(1).Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub

この回答へのお礼

思ったとおりできました。
どうもありがとうございました。

お礼日時：2010/11/19 10:40

No.3 回答者： mitarashi 回答日時： 2010/11/18 22:13

#1です。

コードをご覧になれば分かると存じますので、シート名をお好きな様に変更してお使い下さい。
Sub データ更新3()
Dim sh As Worksheet
Dim destRange As Range, srcRange As Range

With Sheets("シート１")
If .Range("A2").Value = "" Then
Set destRange = .Range("A2")
Else
Set destRange = .Range(.Range("A2"), .Range("A2").End(xlToRight))
Set destRange = .Range(destRange, destRange.End(xlDown))
destRange.ClearContents
Set destRange = destRange.Cells(1)
End If
End With
For Each sh In ActiveWorkbook.Worksheets
Select Case sh.Name
Case "シート２"
Set srcRange = sh.Range("A1").CurrentRegion
srcRange.Copy destRange
Set destRange = destRange.End(xlDown).Offset(1, 0)
Case "シート３", "シート４", "シート５", "シート６"
Set srcRange = sh.Range("A1").CurrentRegion
Set srcRange = Intersect(srcRange, srcRange.Offset(1, 0))
srcRange.Copy destRange
Set destRange = destRange.End(xlDown).Offset(1, 0)
Case Else
'何もしない
End Select
Next sh
End Sub

この回答へのお礼

ありがとうございます。
思ったとおり動きました。

ただ、
シート２は１行目から最終行を
シート１の１行目から転記、

シート３～６は２行目から最終行を
シート１の最終行（前回の転記後の最終行）から転記なのですが

一番最初の
シート２をシート１に転記する所で
シート１の２行目から転記されています。
この時点でシート１の1行目が空白です。
よって転記完了時（シート２～６までが転記された状態）
シート１の１行目が空白行になっています。

記述のどこを修正していいかよく分かりません。
申し訳ありません。

お礼日時：2010/11/19 09:07

No.2 回答者： mu2011 回答日時： 2010/11/18 15:40

一例です。

マクロ記録のコードは操作をシリアルに記録しているだけですから短くするのは難しい。
サンプルですが、以下のコードを標準モジュールに貼り付けてお試しください。

Sub シート結合()
Application.ScreenUpdating = False
Sheets("シート１").Cells.Clear
Sheets("シート２").Range("1:1").Copy Sheets("シート１").Range("A1")
For i = 2 To 6
With Sheets("シート" & Application.Dbcs(i))
最終行 = .Cells(Rows.Count, 1).End(xlUp).Row
最終列 = .Cells(1, Columns.Count).End(xlToLeft).Column
If 最終行 >= 2 Then
開始行 = Sheets("シート１").Cells(Rows.Count, 1).End(xlUp).Row + 1
.Activate
.Range(Cells(2, 1), Cells(最終行, 最終列)).Copy _
Sheets("シート１").Cells(開始行, 1)
End If
End With
Next
Sheets("シート１").Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub

この回答へのお礼

ありがとうございました。

申し訳ありません。
シート２～６ですが
シート名は変更されていました。

シート２：みかん
シート３：いちご
シート３：りんご
シート４：バナナ
シート５：パイン

という感じです。

記述の中には
シート１とシート２しか出ていませんが
シート２をみかんに変更するだけで動くのでしょうか？

お礼日時：2010/11/18 18:31

No.1 回答者： mitarashi 回答日時： 2010/11/17 22:22

短さを狙ってやってみました。

アクティブワークブックには、シート１～６しか存在しない事を前提にしています。
（というか、処理対象外のシートが存在しない事を前提にしています）
もっと分かり易い回答が、他の方からあると存じます。
Sub データ更新2()
Dim sh As Worksheet
Dim destRange As Range, srcRange As Range

With Sheets("シート１")
If .Range("A2") = "" Then
Set destRange = .Range("A2")
Else
Set destRange = .Range(.Range("A2"), .Range("A2").End(xlToRight))
Set destRange = .Range(destRange, destRange.End(xlDown))
destRange.ClearContents
Set destRange = destRange.Cells(1)
End If
End With
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "シート１" Then
Set srcRange = sh.Range("A1").CurrentRegion
If sh.Name <> "シート２" Then Set srcRange = Intersect(srcRange, srcRange.Offset(1, 0))
srcRange.Copy destRange
Set destRange = destRange.End(xlDown).Offset(1, 0)
End If
Next sh
End Sub

この回答へのお礼

>短さを狙ってやってみました。
>アクティブワークブックには、シート１～６しか存在しない事を前提にしています。
>（というか、処理対象外のシートが存在しない事を前提にしています）

申し訳有りません。
シートは1から１０まであります。

その中のシート2～6をシート１に転記したいです。

どうもありがとうございました。

お礼日時：2010/11/18 09:47