セルの移動、貼り付けの繰り返し

質問

お世話になります。

Excel2003を使用しています。

A列からC列まで各行に必ずデーターが入っており、日付の入った各行の下に3行挿入した後、B1の値をA2へ、C1の値をA3へそれぞれ切り取って貼り付け、その下の行は空白にしたく、今現在手作業で行っています。VBAで一括で処理したく、データーがある限り同じように繰り返したいのですがやりかたがわかりません。初心者なので自分で考えたコードも記述していなく、丸投げですみませんが、どなたかご教授していただけませんか？よろしくお願いします。

　　A 　　　 B 　　　　C 　
1　3月1日　大阪　　日帰り
2　3月2日　東京　　出張　　
3　3月3日　名古屋　日帰り　
4　・・　　・・　　・・　

下図のようにしたいのですが。
　　 A 　　　B 　　　　C 　
1　3月1日　
2　大阪
3　日帰り
4　空白
5　3月2日
6　東京
7　出張
8　空白
9　・・

回答No.2

tom04 · ベストアンサー

こんにちは！
関数でもできそうですが、VBAをご希望だというコトですので・・・
一例です。

Sheet1のデータをSheet2に表示するようにしてみました。
Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1() 'この行から
Dim i As Long, cnt As Long, wS1 As Worksheet, ws2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
ws2.Cells.Clear
For i = 1 To wS1.Cells(Rows.Count, 1).End(xlUp).Row
cnt = cnt + 1
wS1.Cells(i, 1).Resize(1, 3).Copy
ws2.Activate
ws2.Cells((cnt - 1) * 4 + 1, 1).Select
Selection.PasteSpecial Paste:=xlAll, Transpose:=True
Next i
Application.ScreenUpdating = True
End Sub 'この行まで

こんな感じではどうでしょうか？m(_ _)m

お礼

できました。
初心者だからといっても、もう少し勉強してから質問しないといけないのに、ご丁寧なご回答ありがとうございました。
非常に助かりました。

回答No.1

noname#204879

マクロを使用しない別解
Sheet2!A1: =IF(MOD(ROW(),4),OFFSET(Sheet1!A$1,(ROW()-1)/4,MOD((ROW()-1),4)),"")
このセルを必要な行数だけ下方にズズーッとドラッグ＆ペースト

お礼

一番早いご回答ありがとうございました。結局はtom04さんのコードで出来ました。
今後もよろしくお願いします。