- 締切済み
複数シートの一定範囲を、他シートの表に貼り付けたい
Win7 Excel2007 でマクロ作成中の初心者です。 複数シートの一定の範囲を、総括表シートの中にある表に貼り付けたいです。 いろいろサイト探しましたが方法がわかりません。どうかご教示おねがいします。 Sub 総括表シートに貼り付け() ' Dim list, sheetName Application.ScreenUpdating = False Const EXCEPT_NAME = "総括表 保管用" For Each sheetName In ActiveWorkbook.Worksheets If InStr(EXCEPT_NAME, sheetName.Name) = 0 Then Sheets(sheetName.Name).Activate ActiveSheet.Unprotect 複貼り付け用部品 ActiveSheet.Protect End If Next End Sub -------------------------------------------- Sub 複貼り付け用部品() ’自動記録のコード 'すべてのシートの Range("AW7:AW34")の範囲を総括表シートに貼り付け '貼り付け位置は、総括表のシートのD列からに順番に貼り付け ActiveSheet.Unprotect Range("AW7:AW34").Select '最初のシート Selection.Copy Range("D4:D31").Select '総括表シートのD列に貼り付け Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("AW7:AW34").Select '2番目のシート Application.CutCopyMode = False Selection.Copy Range("E4:E31").Select '総括表シートのE列に貼り付け Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("AW7:AW34").Select '3番目のシート Application.CutCopyMode = False Selection.Copy Range("F4:F31").Select '総括表シートのF列に貼り付け Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("AW7:AW34").Select '4番目のシート Application.CutCopyMode = False Selection.Copy Range("G4:G31").Select '総括表シートのG列に貼り付け Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '以下続く End Sub
- みんなの回答 (1)
- 専門家の回答
みんなの回答
- n-jun
- ベストアンサー率33% (959/2873)
Sub 総括表シートに貼り付け() ' Dim list, sheetName Dim r_EXCEPT As Range Application.ScreenUpdating = False Const EXCEPT_NAME = "総括表 保管用" Set r_EXCEPT = Worksheets(EXCEPT_NAME).Range("D4:D31") For Each sheetName In ActiveWorkbook.Worksheets If InStr(EXCEPT_NAME, sheetName.Name) = 0 Then With Worksheets(sheetName.Name) .Unprotect r_EXCEPT.Value = .Range("AW7:AW34").Value Set r_EXCEPT = r_EXCEPT.Offset(, 1) .Protect End With End If Next Set r_EXCEPT = Nothing End Sub こんな感じ?
補足
ご回答ありがとうございます。今ご教示いただいたコードを貼り付けて実行したろころ 「インデックスが有効範囲にありません」という実行時エラー9というのが表示されます。 そして、デバックボタンをおすと、 Set r_EXCEPT = Worksheets(EXCEPT_NAME).Range("D4:D31") の行が黄色になります どうしてでしょうか?お世話かけますがよろしくおねがいします。