マクロについて教えてください
マクロの超初心者です。
数式を入力しているのではなく、配付物をエクセルで作成しているのですが、同じもの(氏名や項目は違いますが)を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
お礼
一応、下記のようにして使用できそうです。 処理の早さはさすがに早かったです。 RIGHTBやLEFTBもチャレンジしてみたいとおもいます。 Sub TransferTest1_ST() Dim n As Long Dim myData(24) As Variant 'myDataも24 Dim rng As Range Dim c As Variant Dim i As Long, j As Long, k As Long '最初のrng の部分を決めてくれれば良いです。ただし、隣り合うセルは、{:}でつなぎます。 Set rng = Worksheets("Sheet1").Range("A5,A5,B5,B6,D5,E5,F5,F7,G5,G7,H5,H7,L5,L7,M5,N5,O5,P5,Q5,S5,S6,S7,S8,T6") 'myDataもResizeも24にする↑24個あるから For j = 0 To Cells(Rows.Count, 2).End(xlUp).Row Step 4 '4行置き i = 0 For Each c In rng.Offset(j).Cells myData(i) = c.Value i = i + 1 Next c Worksheets("Sheet2").Range("B2").Offset(k).Resize(, 24).Value = myData() 'Resizeも24 Erase myData() k = k + 1 Next j Set rng = Nothing End Sub
補足
ありがとうございます。 配列は苦手ですが、 処理時間は、早くなりそうな気がするので、 本当は、配列を使った方がよい気がします。 シンプルで短いソースがいいなぁと 作成していくうちに、思うようになりました。 時間はかかるかもしれませんが、 こちらも使って、作ってみたいとおもいます。 レスのつけ方が、いまいちですみません。