Excelで、A列、B列の値を新しいシートに3行ごとにどんどん貼り付け

質問

Excelで、A列、B列の値を新しいシートに3行ごとにどんどん貼り付ける。

という事をしたいのですが、VBAを始めたばかりなので上手く書くことが出来ません。

例）

　　　Ａ列　　　Ｂ列
　　１０１　　りんご　
　　１０２　　ぶどう
　　１０３　　オレンジ
　　１０４　　　桃
　　１０５　　バナナ
　　　　　・
　　　　　・
　　　　　・

これを別のシートに

　　　Ａ列　　　Ｂ列
　　１０１　　りんご
（２行あける）
　　１０２　　ぶどう
（２行あける）
　　１０３　　オレンジ
（２行あける）　
　　１０４　　　桃
（２行あける）　
　　１０５　　バナナ
　　　　　・
　　　　　・
　　　　　・

と表示したいのです。
現在は下記のようなリンクで表示していますが、
件数が少ない時は４件から多い時は８００件と幅があります。
出来れば表の一番下（空欄になる部分）まで繰り返し処理をしたいと思っています。
セルの中身が表示されるならリンクでもコピーでも構いません。

現在のマクロ
Sub Macro2()

Worksheets("Sheet2").Select
Range("C11").Value="=Sheet1!A2"
Range("C14").Value="=Sheet1!A3"
Range("C17").Value="=Sheet1!A4"
Range("C20").Value="=Sheet1!A5"
Range("C23").Value="=Sheet1!A6"

Range("H11").Value="=Sheet1!B!"
Range("H14").Value="=Sheet1!B2"
Range("H17").Value="=Sheet1!B3"
Range("H20").Value="=Sheet1!B4"
Range("H23").Value="=Sheet1!B5"

End sub

４５行分まで書いたところで途方に暮れております。
よろしくお願いいたします。

回答No.2

mt2008 · ベストアンサー

Sheet1のデータ数を取得する方法が判らないのか、ループを回す発想が無いのか……と、言った所でしょうか。

Sheet1のA列の空欄までの行数は、↓これで求まります。
Sheets("Sheet1").Range("A1").End(xlDown).Row

あとは、その行数分ループを回してSheet2に値を入れて行けば良いです。

やりたい事と、現在のマクロが一致していないので、やりたい事の方を実現するサンプルを提示します。適当に変更してください。

Sub Sample()
　Dim nTotal, i
　nTotal = Sheets("Sheet1").Range("A1").End(xlDown).Row 'Sheet1の最終行

　With Sheets("Sheet2")
　　.Columns("A:B").ClearContents 'Sheet2のA、B列をクリア
　　For i = 1 To nTotal
　　　.Cells(i * 3 - 2, 1).Value = Sheets("Sheet1").Cells(i, 1).Value
　　　.Cells(i * 3 - 2, 2).Value = Sheets("Sheet1").Cells(i, 2).Value
　　Next i
　End With
End Sub

お礼

おっしゃる通り希望はループです……
何せ本当に始めたばかりなのであちこちのサイトにある
例文のループを改変出来ずにおりました。
ありがとうございます。早速明日試してみます。
結果はまたご報告させていただきますね。

補足

お返事が遅くなって申し訳ありません。
自宅のパソコンが壊れてお返事できずにおりました……

無事変更も出来て希望通りにループされることができました。
本当にありがとうございます。

回答No.1

kagakusuki

次の様な方法では駄目なのでしょうか。
　今仮に、元のデーターが入力されているシートをSheet1、リストの最上段がシートの1行目に入力されているものとします。
　まず、2行置きに表示するシートのA1セルに、次の数式を入力して下さい。

=INDEX(Sheet1!A:A,(ROWS($1:1)-1)/3+1)

　次に、A1セルをコピーして、B1セルに貼り付けて下さい。
　それから、A1～B1の範囲をコピーして、4行目に貼り付けて下さい。
　そして、2～4行目を範囲選択してから、Excelのドラッグ機能を使用して、5行目以下の行に数式をコピーして下さい。
　尚、このままではSheet1の何も入力されていないセルを参照した場合には、0と表示されてしまいますから、以下の様な方法で0が表示されない様に、シートの設定を変更して下さい。

メニューバーの[ツール]ボタンをクリック
　　↓
現れた選択肢の中にある[オプション]をクリック
　　↓
現れた「オプション」ウィンドウの[表示]タグをクリック
　　↓
「ウィンドウ オプション」欄にある「ゼロ値」のチェックを外す
　　↓
[ＯＫ]ボタンをクリック

　これで、0が表示されなくなります。
　尚、Sheet1の何も入力されていないセルを参照する場合にのみ0を表示しない様にし、数値の0が入力されているセルを参照する場合には、0を表示させる場合は、「ゼロ値」のチェックを入れて、A1セルに入力する数式を次の様に変更して下さい。

=IF(INDEX(Sheet1!A:A,(ROWS($1:1)-1)/3+1)="","",INDEX(Sheet1!A:A,(ROWS($1:1)-1)/3+1))

お礼

ありがとうございます。明日早速試してみます。
またご報告させていただきますね。