複数シートをループさせてマクロを簡素化したい

質問

win7 Excel2007 でマクロ作成中の初心者です。
シート数の変動する複数シートの特定範囲を一枚のシートに右列方向に、値を貼り付けたいです。
自動記録でコード作成しましたが、もっと簡素化して軽くしたいです。
シートに対するループ等の作成ができません。どうかご指導お願いします。
Sub 勤怠最終データ作成()
Worksheets(1).Select '1番左のシートを選択
ActiveSheet.Unprotect
Range("B29:BM60").Select '複写範囲はすべて同じ
Selection.Copy
Sheets("総括").Select '値の貼り付けシートはすべて同じ
Range("A2").Select '値の貼り付け先
Selection.PasteSpecial Paste:=xlPasteValues
’--------------------------------------
Worksheets(2).Select '2枚目のシートを複写
ActiveSheet.Unprotect
Range("B29:BM60").Select
Selection.Copy
Sheets("総括").Select
最終セルの選択 '値の貼り付け先
Selection.PasteSpecial Paste:=xlPasteValues
’--------------------------------------
Worksheets(3).Select '3枚目のシートを複写
ActiveSheet.Unprotect
Range("B29:BM60").Select
Selection.Copy
Sheets("総括").Select
最終セルの選択
Selection.PasteSpecial Paste:=xlPasteValues
’--------------------------------------
Worksheets(4).Select '4枚目のシートを複写
ActiveSheet.Unprotect
Range("B29:BM60").Select
Selection.Copy
Sheets("総括").Select
最終セルの選択
Selection.PasteSpecial Paste:=xlPasteValues
以下省略
End Sub

回答No.3

tom04 · ベストアンサー

No.1・2です！
続けておじゃまします。

よく確認せずに投稿してごめんなさい。
「値」の貼り付けですね！

セルの結合は無視されてしまいますが・・・

Sub test()
Dim k As Long
Dim ws As Worksheet
Set ws = Worksheets("総括")
Application.DisplayAlerts = False
On Error Resume Next
For k = 1 To Worksheets.Count
If Worksheets(k).Name <> "総括" Then
Range(Worksheets(k).Cells(29, "B"), Worksheets(k).Cells(60, "BM")).Copy
ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
End If
Next k
Range(ws.Cells(2, 1), ws.Cells(60, 1)).Delete (xlToLeft)
ws.Cells(2, 1).Select
End Sub

※　今回は「総括」Sheetがどこにあっても対応できるようにしてみました。
こんなんで参考になりますかね？m(_ _)m

お礼

私の思っている通りのことが実現できました。本当に感謝感激です。そのコードを見たとき半分ほどしか理解できず、まるでマジックショーを見ているようです。大変おせわになりました。今後共よろしくお願いします。

回答No.2

tom04

No.1です！
補足の
＞上のせる範囲には横方向のセルの結合がしてあります。

とありますがコピー元のSheetが結合されているのか？それとも「総括」Sheetが結合されているのか？
判らないのですが、
場合によっては結合を解除してやる必要があるかもしれません。

とりあえずコードを↓に変更してみてください。

Sub test()
Dim k As Long
Dim ws As Worksheet
Set ws = Worksheets("総括")
Application.DisplayAlerts = False
On Error Resume Next
For k = 2 To Worksheets.Count
Range(Worksheets(k).Cells(29, "B"), Worksheets(k).Cells(60, "BM")).Copy Destination:= _
ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
Next k
ws.Range(Cells(2, 1), Cells(60, 1)).Delete (xlToLeft)
End Sub

エラーを無視するようにしてみましたが、これでもダメなら
別方法（セルの結合解除等）を考える必要があるかもしれません。

その場合は具体的な表のレイアウトが判らないと
的確なアドバイスができないと思います。

この程度でごめんなさいね。m(_ _)m

補足

教えていただいたコードを実行したとろこ、すべての貼り付けになっていまして、セルに入っている関数がそのままなので、値の貼り付けでないので、このセルの値のデータを利用して再加工することができません。
各シートのコピー元が横結合しています。コピー先は一切結合していません。どうぞよろしくおねがいします。

回答No.1

tom04

こんにちは！
「総括」SheetはSheet見出し上で一番左側にあるとします。

標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub test()
Dim k As Long
Dim ws As Worksheet
Set ws = Worksheets("総括")
For k = 2 To Worksheets.Count
Range(Worksheets(k).Cells(29, "B"), Worksheets(k).Cells(60, "BM")).Copy Destination:= _
ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
Next k
ws.Range(Cells(2, 1), Cells(60, 1)).Delete (xlToLeft)
End Sub

※　各SheetのBM2セルには何らかのデータが入っているとします。
（そうでないと、最終列の取得が滅茶苦茶になってしまいます）

こんな感じでよろしいのでしょうか？m(_ _)m

補足

素早いご回答ありがとうございます。私の自動記録のマクロで作動したのですが、ご指摘のコードを実行したところ、「コピー領域と貼り付け領域の形が・・・で貼り付けできません。」のエラーがでます。前もってお知らせすべきでした。上のせる範囲には横方向のセルの結合がしてあります。まさかのショックです。
どうしたらよろしいでしょうか。