複数シートの選択範囲を一枚のシートに貼り付ける

質問

Excel2007使用のマクロ初心者です。
以下のコードで正常に、動作しています。
複数シートのセルＢ29からＢＱ60までのセル範囲を
「計算シート」の一枚に右列方向に、順次貼りつけています。

しかしこれは不要な部分も貼り付けしてるので
セル範囲をＢ29からＩ60までと
ＢＭ29からＢＭ60までの２箇所を、上記同様に「計算シート」に
右列方向に貼りつけていきたいです。
このコードをどう修正したらよいでしょうか。また別方法ありますでしょうか。

Sub 計算表の一括複写()
Application.ScreenUpdating = False

Dim list, SheetName
ActiveSheet.Unprotect
Const EXCEPT_NAME = "　年月管理　 最新明細　記録帳"
Worksheets("計算").Activate
Rows("2:33").Select
Selection.Delete Shift:=xlUp

Dim k As Long
Dim ws As Worksheet
Set ws = Worksheets("計算")
Application.DisplayAlerts = False
On Error Resume Next
For k = 1 To Worksheets.Count - 8
If Worksheets(k).Name <> "計算" Then
Range(Worksheets(k).Cells(29, "B"), Worksheets(k).Cells(60, "BQ")).Copy
ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
End If
Next k
Application.CutCopyMode = False
空白列の削除
End Sub

回答No.1

kybo · ベストアンサー

★印の部分の処理を2回繰り返せばいいだけです。

Sub 計算表の一括複写()
Application.ScreenUpdating = False

Dim list, SheetName
ActiveSheet.Unprotect
Const EXCEPT_NAME = "　年月管理　 最新明細　記録帳"
Worksheets("計算").Activate
Rows("2:33").Select
Selection.Delete Shift:=xlUp

Dim k As Long
Dim ws As Worksheet
Set ws = Worksheets("計算")
Application.DisplayAlerts = False
On Error Resume Next
For k = 1 To Worksheets.Count - 8
If Worksheets(k).Name <> "計算" Then
'★
Range(Worksheets(k).Cells(29, "B"), Worksheets(k).Cells(60, "I")).Copy
ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
’★
Range(Worksheets(k).Cells(29, "BM"), Worksheets(k).Cells(60, "BM")).Copy
ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
End If
Next k
Application.CutCopyMode = False
空白列の削除
End Sub

★の書き方だと長すぎるので、

Worksheets(k).Range("B29:I60").Copy
ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteValues

Worksheets(k).Range("BM29:BM60").Copy
ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteValues

の方がわかりやすく、すっきりします。

お礼

ありがとうございました。早速やってみたら完璧に、しかも軽くなった分、肩もこらずにすいすいできました。本当に感謝もうしあげます。