マクロについて教えてください

質問

マクロの超初心者です。
数式を入力しているのではなく、配付物をエクセルで作成しているのですが、同じもの（氏名や項目は違いますが）を100枚ほど作成しているのでマクロを・・・と思ったのですがやり方が全く分かりません。

sheet1からsheet2に下記のようにデータを写したいのですが、やり方を教えてください。

●氏名が入力されています
sheet1（A9) →　sheet2(C2)
sheet1（E9) →　sheet2(C5)
sheet1（I9) →　sheet2(C8)

●項目1
sheet1（A8) →　sheet2(E3)
sheet1（E8) →　sheet2(E6)
sheet1（I8) →　sheet2(E9)

●項目2
sheet1（A18～D18の結合セル) →　sheet2(E2)
sheet1（E18～H18の結合セル) →　sheet2(E5)
sheet1（I18～L18の結合セル) →　sheet2(E8)

と反映させたいのですが、250行あるのですが、
簡単にマクロで出来ないでしょうか？？

ちなみに↓コレが上記の内容で作ってみたものです。

わかりずらい質問でスイマセン。

Range("A9").Select
Selection.Copy
Sheets("sheet2").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("sheet1").Select
Range("E9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("sheet2").Select
Range("C5").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("sheet1").Select
Range("I9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("sheet2").Select
Range("C8").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("sheet1").Select
Range("A8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("sheet2").Select
Range("E3").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("sheet1").Select
Range("E8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("sheet2").Select
Range("E6").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("sheet1").Select
Range("I8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("sheet2").Select
Range("E9").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("sheet1").Select
Range("A18:D18").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("sheet2").Select
Range("E2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("sheet1").Select
Range("E18:H18").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("sheet2").Select
Range("E5").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("sheet1").Select
Range("I18:L18").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("sheet2").Select
Range("E8").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End Sub

回答No.3

n-jun · ベストアンサー

＃２です。

＞ちなみに、今回は250回と限定とのことでしたが、
＞もっと増やす場合はどのようにしたらよろしいのでしょうか？？

For j = 0 To 249
これが０～２４９で２５０回としてます。
３００回なら
For j = 0 To 299
と（回数－１）を入れて下さい。

お礼

本当にありがとうございました！

ここ数日悩んでいた事が一気に解決することができました。

お陰で期日までに配付できそうです。

回答No.2

n-jun

＃１です。

２５０回と言うのが固定なら。

Sub try_2()
Dim ws As Worksheet
Dim i As Integer, j As Integer
Dim v As Variant

Set ws = Worksheets("Sheet1")
v = Array("A18", "E18", "I18")

With Worksheets("Sheet2")

For j = 0 To 249
For i = 0 To 2
.Range("C2").Offset(i * 3 + j * 9).Value = ws.Range("A9").Offset(j * 25, i * 4).Value
.Range("E3").Offset(i * 3 + j * 9).Value = ws.Range("A8").Offset(j * 25, i * 4).Value
.Range("E2").Offset(i * 3 + j * 9).Value = ws.Range(v(i)).Offset(j * 25).Value
Next
Next

End With
Set ws = Nothing
End Sub

とかでしょうか。
ご参考まで。

お礼

ご丁寧に本当にありがとうございます。
大変助かりました！！

ちなみに、今回は250回と限定とのことでしたが、
もっと増やす場合はどのようにしたらよろしいのでしょうか？？

回答No.1

n-jun

提示された１回分なら。

Sub try()
Dim ws As Worksheet
Dim i As Integer
Dim v As Variant

Set ws = Worksheets("Sheet1")
v = Array("A18", "E18", "I18")

With Worksheets("Sheet2")

For i = 0 To 2
.Range("C2").Offset(i * 3).Value = ws.Range("A9").Offset(, i * 4).Value
.Range("E3").Offset(i * 3).Value = ws.Range("A8").Offset(, i * 4).Value
.Range("E2").Offset(i * 3).Value = ws.Range(v(i)).Value
Next

End With
Set ws = Nothing
End Sub

でも出来るかと思います。
ご参考程度に。

お礼

ありがとうございます！！
内容はサッパリ分かりませんでしたが、
コピーして実行したらできました。

そして、私の説明不足でしたが250行というのは
下記のような規則性があります。

●氏名
sheet1（A9) →　sheet2(C2)
sheet1（E9) →　sheet2(C5)
sheet1（I9) →　sheet2(C8)

sheet1（A34) →　sheet2(C11)
sheet1（E34) →　sheet2(C14)
sheet1（I34) →　sheet2(C17)

●項目1
sheet1（A8) →　sheet2(E3)
sheet1（E8) →　sheet2(E6)
sheet1（I8) →　sheet2(E9)

sheet1（A33) →　sheet2(E12)
sheet1（E33） →　sheet2(E15)
sheet1（I33) →　sheet2(E18)

●項目2
sheet1（A18～D18の結合セル) →　sheet2(E2)
sheet1（E18～H18の結合セル) →　sheet2(E5)
sheet1（I18～L18の結合セル) →　sheet2(E8)

sheet1（A43～D43の結合セル) →　sheet2(E11)
sheet1（E43～H43の結合セル) →　sheet2(E14)
sheet1（I43～L43の結合セル) →　sheet2(E17)

つまり、
sheet1：A、E、I列の25行置きに入力されている文言を
sheet2：C or E列に3行置きに反映させたい

これを250行分行いたいのですが、どのようにすればよろしいでしょうか？

また、空白の部分があってもエラー無しで行いたいのですが、
よろしくお願いいたいします。