Excelマクロ 別シートへ連続コピペの方法

質問

Excelマクロ初心者です。

現在以下のような作業をマクロを組もうとしています。

シート１のA3:A9の数値をコピー→シート1の右隣のシート（仮にシート２とします）のC3:C9へペースト→シート１へ戻りB3:B9の数値をコピー→隣の隣のシート（仮シート２の右隣のシート）のC3:C9へペースト

というのをシート1のAA3:AA9まで繰り返したいです。

こういうマクロを組むのは可能なのでしょうか？
もし組めるとしたらどのように組めばいいか教えて頂きたいです。

よろしくお願いします。

回答No.5

K Kazz（@JazzCorp）

'再挑戦！！

Sub CopyCyclicPartialRange()
Const xRange_Row = 3
Const xRange_Row2 = 9
Const xRange_Rows = xRange_Row2 - xRange_Row + 1
Const xColumn_From = 1
Const xColumn_To = 27
Const xBase = "C3"
Const xSheet = "シート1"
Dim jj As Long
Dim kk As Long
Dim mm As Long
Dim nn As Long

Application.ScreenUpdating = False
For kk = 1 To ThisWorkbook.Sheets.Count
If Worksheets(kk).Name = xSheet Then
mm = kk
Exit For
End If
Next kk
If (mm <> kk) Then
MsgBox ("""" & xSheet & """？ ご指定のシートが見つかりませんでした、残念～ん！" & vbCrLf & "再度挑戦する場合は、「xSheet」に元ネタのシート名を設定してね！")
GoTo Epilogue
End If
kk = ThisWorkbook.Sheets.Count - (mm + xColumn_To)
If (kk < 0) Then
MsgBox ("このミッションを成功させるためには、シートがあと" & -kk & "個必要のようです、残念～ん！" & vbCrLf & "再度挑戦する場合は、シートを追加してね！")
GoTo Epilogue
End If
With Worksheets(xSheet)
For kk = 1 To xColumn_To
.Range(.Cells(xRange_Row, kk), .Cells(xRange_Row2, kk)).Copy
Worksheets(mm + kk).Range(xBase).Resize(xRange_Rows, 1).PasteSpecial Paste:=xlValues
Next kk
End With
Epilogue:
Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。
非常に助かりました。
おかげで作業がガンガン進みます！

回答No.4

米沢 栄蔵（@YON56）

経験上、コピー&ペーストは時間がかかるので、
数値をコピーをデータの移動と考えてマクロを記述します。

Dim A,B,X,Y,AAA()
X=27 'A列からAA列までの列数
Y=7 '3行から9行までの行数
ReDim AAA(X,Y)
'移動対象データの取得
Sheets("シート１").Select
For A=1 To X
For B=3 To Y+2
AAA(X,Y)=Cells(A,B).Value
Next B
Next A
'取得データの移動対象への書込
Sheets("シート２").Select
For A=1 To X
For B=3 To Y+2
Cells(A,B)=AAA(X,Y)
Next B
Next A

お礼

非常にわかりやすいです。
ありがとうございます

回答No.3

keithin

こんばんは。

＞コピー→シート1の右隣のシート（仮にシート２とします）のC3:C9へペースト

いわずもがなですが元のシートのＡ３：ＡＡ９の内容は、生数字などですね。
数式とかで、「ただコピーしただけじゃ勝手に計算結果が変わっちゃいました」みたいなのじゃありませんね？ということです。

ご質問に書かれてることだけなら特に難しい事もなく、淡々とコピー貼り付けてくだけの単純なマクロで出来ます。

sub macro1()
　dim o, i
　o = activesheet.index

　on error goto errhandle
　for i = 1 to 27
　worksheets(o).range("A3:A9").offset(0, i - 1).copy worksheets(o + i).range("C3")
　next i
　exit sub

errhandle:
　worksheets.add after:=worksheets(worksheets.count)
　resume
end sub

お礼

すごく単純ですね！
わからないことだらけなので、今後勉強して行こうと思います。
ありがとうございました。

回答No.2

tom04

こんばんは！

一例です。
Alt＋F11キー　→　メニューの挿入　→　標準モジュールに↓のコードをコピー＆ペーストして
マクロを実行してみてください。
尚、Sheet数はsheet1を含めて全部で28Sheetあるという前提です。

Sub test1() 'この行から
Dim k As Long, ws As Worksheet
Set ws = Worksheets("Sheet1") '←「Sheet1」は実際のSheet名に！
For k = 2 To Worksheets.Count
Range(ws.Cells(3, k - 1), ws.Cells(9, k - 1)).Copy Destination:=Worksheets(k).Range("C3")
Next k
End Sub 'この行まで

こんな感じではどうでしょうか？

※　Sheetを追加してコピー＆ペーストする場合は当然コードも変わってきます。m(_ _)m

お礼

短くシンプルでわかりやすいです。
ありがとうございます。

＊の点は大丈夫です。

回答No.1

K Kazz（@JazzCorp）

Sub CopyCyclicPartRange()
Const xRange_Row = 3
Const xRange_Row2 = 9
Const xRange_Rows = xRange_Row2 - xRange_Row + 1
Const xColumn_From = 1
Const xColumn_To = 27
Const xBase = "C3"
Const xSheet = "シート1"
Dim jj As Long
Dim kk As Long
Dim mm As Long
Dim nn As Long

Application.ScreenUpdating = False
For kk = 1 To ThisWorkbook.Sheets.Count
If Worksheets(kk).Name = xSheet Then
mm = kk
Exit For
End If
Next kk
With Worksheets(xSheet)
For kk = 1 To xColumn_To
.Range(.Cells(3, kk), .Cells(9, kk)).Copy
Worksheets(mm + kk).Range(xBase).Resize(xRange_Rows, 1).PasteSpecial Paste:=xlValues
Next kk
End With
Epilogue:
Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。

しかし「実行時エラー'9'、インデックスが有効範囲にありません」と出て来てしまいます。
どこがおかしいのでしょうか？