エクセル マクロ VBA

データを交互に貼り付けるマクロを組みたいです。

添付した画像のようなデータが貼り付けられたシートがあります。
これを別のシートに
データ①
データ②
データ③
・
・
・
と、貼り付けたいです。
データは各2列(X,Y)あり、空欄はありません。
データの個数もみな同じです。

説明下手で申し訳ありませんが、よろしくお願いいたします。

No.3 回答者： zongai 回答日時： 2020/09/23 16:39

> 加えて質問よろしいでしょうか？

> データのある同じシートには下の行にまだデータがありまして、それも縦に並べたいのですが、どのようにすればよいでしょうか？
> （22行目から同様にデータが入っています）

質問の画像だと30行近いデータ量のイメージですが…
・1データが21行以内である
・2段めのデータが22行目から始まる
という前提だけで即席で作るなら、
1段目の処理に手を加えて2段めを処理。

Sub SAMPLE_2()
　　'シート名取得　コピペ元
　　s = ActiveSheet.Name
　　'データ列数
　　c = 2
　　'データ行数
　　r = 20
　　'シート追加
　　Sheets.Add After:=ActiveSheet
　　'コピペ先が決まってるなら 上の処理は削除、下の「'」を消してシート名入力
　　'Sheets("Sheet2").Select
　　'コピペ
　　i = 1
　　With Sheets(s)
　　Do Until .Cells(1, (i - 1) * c + 1) = ""
　　　　Range(.Cells(1, (i - 1) * c + 1), .Cells(r, (i - 1) * c + c)).Copy
　　　　Cells((i - 1) * r + 1, 1).Select
　　　　ActiveSheet.Paste
　　　　i = i + 1
　　Loop
　　r2 = Selection.Row + r　'1段目情報書き終わりの行情報
　　i = 1
　　Do Until .Cells(22, (i - 1) * c + 1) = ""
　　　　Range(.Cells(22, (i - 1) * c + 1), .Cells(r + 21, (i - 1) * c + c)).Copy
　　　　Cells((i - 1) * r + r2, 1).Select
　　　　ActiveSheet.Paste
　　　　i = i + 1
　　Loop
　　End With
End Sub


より汎用性を求めるなら、まだまだ手を加える必要はあるけどね。
とりあえず、これらをベースにいじれば急場はしのげるんでしょ？

この回答へのお礼

再度の回答ありがとうございます。
なんとか形にできました。

お礼日時：2020/09/23 16:48

No.2 回答者： fujillin 回答日時： 2020/09/23 15:12

こんにちは

回答ではありませんが・・・

＞データ①
＞データ②
＞・・・
というのは、A列とB列の2列に並べ直したいという意味と解釈しました。

元のデータのあるシートを「Sheet1」、折返しの行数（=縦のデータ数）を「最大行」とするなら、別のシートのA1セルに
=OFFSET(Sheet1!$A$1,MOD(ROW()-1,最大行),INT((ROW()-1)/最大行)*2+COLUMN()-1)
の式を入れて、B1にコピーし、更にA1:B1を下方に必要なところまでフィルコピーすれば実現できると思います。

関数式の場合の利点は、マクロのようにいちいち実行しなくても、自動的に変更も反映される点でしょうか。
もしも、関数式で残さずに「セルの値」として欲しい場合には、「A:B列をコピー」 → 「値をペースト」することで、値を固定値化することもできます。

この回答へのお礼

早速式を入れてみたのですが、ほとんど希望通りの動作になりました。ありがとうございます。
関数を使用する方法もあるのですね。
今回はデータ数があまりにも多く、フィルコピーが手間なので、今回の知識はまた別の機会に活かそうと思います。

お礼日時：2020/09/23 16:05

No.1 ベストアンサー 回答者： zongai 回答日時： 2020/09/23 15:00

ざっくり。

交互に貼り付けるっていうより、
順番に縦に連結する、って感じでいいの？

Sub SAMPLE()
　　'シート名取得　コピペ元
　　s = ActiveSheet.Name
　　'データ列数　
　　c = 2
　　'データ行数
　　r = 20
　　'シート追加
　　Sheets.Add After:=ActiveSheet
　　'コピペ先が決まってるなら 上の処理は削除、下の「'」を消してシート名入力
　　'Sheets("Sheet2").Select
　　'コピペ
　　i = 1
　　With Sheets(s)
　　Do Until .Cells(1, (i - 1) * c + 1) = ""
　　　　Range(.Cells(1, (i - 1) * c + 1), .Cells(r, (i - 1) * c + c)).Copy
　　　　Cells((i - 1) * r + 1, 1).Select
　　　　ActiveSheet.Paste
　　　　i = i + 1
　　Loop
　　End With
End Sub

この回答へのお礼

求めていた動作になりました。ありがとうございます。
加えて質問よろしいでしょうか？
データのある同じシートには下の行にまだデータがありまして、それも縦に並べたいのですが、どのようにすればよいでしょうか？
（22行目から同様にデータが入っています）

お礼日時：2020/09/23 16:03