【Excel VBA】別シートの表へそれぞれ1行おきにデータを貼り付けしたいです

Excelで、以下(例)のようにSheet1のB列(数量A)の値を、Sheet2のB列(数量)に1行おきに、同じくC列(数量B)の値を、Sheet2のB列に1行おきに貼り付けをVBAでおこないたいです。
ｺｰﾄﾞを教えてください。

例）

【Sheet1】
A列 　 B列 　 C列
1 品目　　数量A 　 数量B
2 りんご 　1 　 1.2
3 みかん 　4 　　 10.63
4 ぶどう 　10 　　 80
　・ ・ 　　・
　・ ・ 　　・
　　＜B列とC列の値それぞれをｺﾋﾟｰ＞
　　　　　　　↓
　　＜B列に値を1行おきに貼り付け＞
【Sheet2】
　A列　　　 B列
1 品目　 　　数量
2 りんご 　　1 　　　　　　←（数量A)
3 りんご 　　1.2 　　　 ←（数量B)
4 みかん 　　4 　　　　　　←（数量A)
5 みかん 　　10.63 　　　 ← (数量B)
6 ぶどう 　　10 　　　 ←（数量A)
7 ぶどう 　　80 　　　 ← (数量B)　


実際に使用する表に関して
　・"品目"のﾃﾞｰﾀは500近くあり、表の行数も増減します。
　・"品目"のﾃﾞｰﾀはSheet1と2で行数が1行使用と2行使用の違いで並びは一緒です。

1行おきで貼り付けで考えてはいますが（それしか考えつかなかったのですが…）方法は貼り付けにこだわっていません。結果的に同じであれば、別のもっと効率のいい方法があればそちらでも構いません。

よろしくお願いします。

質問者からの補足コメント

• ちなみに貼り付け先のSheet2には品目はすでに入力されています。

    補足日時：2016/06/05 20:45

• 「…貼り付けにこだわっていません。結果的に同じであれば、別のもっと効率のいい方法があればそちらでも構いません。」と書いたのですが…
  ⇒実際の表は、Sheet2の品目は本質問とは別の表中別データに絡んでいるためSheet2品目をいじらない方法でお願いします。わがまま言ってすみません…
  
  ・ちなみに実際の表のSheet2：B列は、F列にあり品目列とは離れていて行は12行目から開始位置になっています。例で参考できるコードを教えてもらい自力で調整できればと思っています。

    補足日時：2016/06/06 01:29

No.1 回答者： tom04 回答日時： 2016/06/05 21:52

こんばんは！

一例です。標準モジュールにしてください。

Sub Sample1()
Dim i As Long, lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet1")
With Worksheets("Sheet2")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(.Cells(2, "A"), .Cells(lastRow, "B")).ClearContents
End If
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(2) = wS.Cells(i, "A")
With .Cells(Rows.Count, "B").End(xlUp)
.Offset(1) = wS.Cells(i, "B")
.Offset(2) = wS.Cells(i, "C")
End With
Next i
End With
End Sub

※　Sheet2のA列も一緒に表示するようにしています。m(_ _)m

この回答へのお礼

早速の回答ありがとうございます。
ためしてみました。さすがです！
質問には全然書かなかったので非常に申し訳なかったのですが、このコードでSheet2の品目を消さないバージョンで修正できるのでしょうか？試行錯誤してますが、初心者のためやはりよくわかりませんでした。是非ともまたご教授願いたいです。

お礼日時：2016/06/06 01:40

No.2 ベストアンサー 回答者： tom04 回答日時： 2016/06/06 08:18

No.1です。

＞Sheet2：B列は、F列にあり品目列とは離れていて行は12行目から開始位置になっています。

要するにSheet1のB2・C2セル以降のデータをSheet2のF12セル以降に縦にコピー＆ペーストすれば良いのですね？

Sub Sample2()
Dim i As Long, myRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
myRow = 10
With Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
myRow = myRow + 2
.Cells(i, "B").Resize(, 2).Copy
wS.Cells(myRow, "F").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Next i
Application.CutCopyMode = False
End With
End Sub

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

この回答へのお礼

再度の回答ありがとうございます。
実際の表で動作確認してみました。
考えたとおりをＶＢＡにすればこうなるよ！って感じになっていました。
マクロ実行に表の行数によるとおもいますが、けっこう時間がかかるのと実行したときにチラチラしました（多分これは仕方のないことなんですよね？）
でも自分でもそこは修正できました。
ありがとうございました。

お礼日時：2016/06/08 10:07

No.3 回答者： CoalTar 回答日時： 2016/06/06 11:01

F列の12行目から数式が入るってことでいいのかな

ほとんど数式で
Sub test2()
With Sheets("Sheet2").Range("F12:F" & Range("a65535").End(xlUp).Row)
.FormulaR1C1 = "=INDEX(Sheet1!C[-4]:C[-3],ROW(R[-8]C[-5])/2,MOD(ROW(R[-8]C[-5]),2)+1)"
.Value = .Value
End With
End Sub

No.4 回答者： CoalTar 回答日時： 2016/06/06 11:34

ちょっと修正

Sub test2()
　With Sheets("Sheet2").Range("F12:F" & Sheets("Sheet2").Range("a65535").End(xlUp).Row)
　 　.FormulaR1C1 = "=INDEX(Sheet1!C[-4]:C[-3],ROW(R[-8]C[-5])/2,MOD(ROW(R[-8]C[-5]),2)+1)"
　 　.Value = .Value
　End With
End Sub

単純に Sheet2!F12:F??セル範囲に
=INDEX(Sheet1!B:C,ROW(A4)/2,MOD(ROW(A4),2)+1)
を入力して[Ctrl]+[Enter]
数式を値化

この回答へのお礼

回答ありがとうございます。
なるほど！です。
これをマクロを使用する場合、表の行が増減したとき、セル範囲のコードを修正することになるってことですよね…
セルに関数を直接入れてもできるってことですよね。
でも自分のレベルでも教えていただいたこのコードを参考にしてアレンジできそうです。
勉強なります！
ありがとうございました。

お礼日時：2016/06/08 10:06