Excel整形処理：列ごと＆12行おきに「行列を入れ替えて貼り付け」

質問

ExcelデータをVBAで次のように処理したいのですが、ご助力いただけますでしょうか。

Sheet1のD列とE列に4万行ほどの数値データがあります（行数は必ず12で割り切れます）。
このデータを、列ごと＆12行おきに「行列を入れ替えて貼り付け」みたいなことをSheet2に
施したいです。具体的なイメージとしては、

【処理前】
D列　E列
----------
D1　E1
D2　E2
D3　E3
：（略）
D35　E35
D36　E36
：（略）

【処理後】
D1　D2　D3　D4　D5　D6　D7　D8　D9　D10　D11　D12　E1　E2　E3　E4　E5　E6　E7　E8　E9　E10　E11　E12■ここで改行
D13　D14　D15　D16　D17　D18　D19　D20　D21　D22　D23　D24　E13　E14　E15　E16　E17　E18　E19　E20　E21　E22　E23　E24■ここで改行
D25　D26　D27　D28　D29　D30　D31　D32　D33　D34　D35　D36　E25　E26　E27　E28　E29　E30　E31　E32　E33　E34　E35　E36■ここで改行
：（略）

なお、テキストエディタを介することによってなら、解決策が見つかりました。
(1) E列の右（＝F列）に12行ごとに＠などの目印をつけます。
(2) E列、F列を選択・コピーし、テキストエディタに貼りつけます。
(3) 置換でまず\nを全て除去し、次にもう一度置換で\t＠を\nに。
(4) D列も同様の手順です。

回答No.2

yambejp · ベストアンサー

SHEET1のD1～E48000を入れ替えながら、SHEET2のA1から
始まる縦2000x横24のデータへ変換するマクロです。
エクセルマクロの基本として、一度配列に落としてから
シートに流し込む方が効率がよいです。
配列は0から始まりますがCELLSは1から始まるため、
若干混乱するかもしれません。

max_col = 24
max_row = 2000

Dim a()
ReDim a(max_row - 1, max_col - 1)
For i = 0 To max_col - 1
For j = 0 To max_row - 1
a(j, i) = Sheets("Sheet1").Range("D1").Offset((i Mod 12) + 12 * j, i \ 12)
Next
Next

Sheets("Sheet2").Range(Cells(1, 1), Cells(max_row, max_col)).Value = a

補足

yamabejpさん、いつもお世話になります。

例示いただいたものは、Sheet1にあったデータを、
Sheet2のA1から（24列目である）X2000セルまで見事に転記してくれます。
ありがとうございます。

さて、もう1回戦追加で、
Sheet1にあるデータ　＝＝＝＞　Sheet3!A1:X2000に、
Sheet2にあるデータ　＝＝＝＞　Sheet3!Y1:AV2000にと、
それぞれ転記する場合、元回答のスクリプトを以下のように改造しましたが、
どうもうまくいきません。何か、変数を上書きしたりしているのでしょうか？
あるいは、Offsetの扱いがよくわかっていないので、そこかもしれません、

以下、何が誤りでしょうか？
（aというのは、昨日のご回答で使っているので、意味ないかもしれませんが
　避けてます）

max_col = 24
max_row = 2000

Dim c()
ReDim c(max_row - 1, max_col - 1)
For o = 0 To max_col - 1
For p = 0 To max_row - 1
c(p, o) = Sheets("Sheet1").Range("D1").Offset((o Mod 12) + 12 * p, o \ 12)
Next
Next
Sheets("Sheet3").Range(Cells(1, 1), Cells(max_row, max_col)).Value = c

Dim d()
ReDim d(max_row - 1, max_col - 1)
For q = 0 To max_col - 1
For r = 0 To max_row - 1
d(r, q) = Sheets("Sheet2").Range("D1").Offset((q Mod 12) + 12 * r, q \ 12)
Next
Next
Sheets("Sheet3").Range(Cells(1, 25), Cells(max_row, max_col)).Value = d

回答No.6

imogasi

こういうループの表現の方がすっきりするのでは。
５００行でテスト済み。４００００行なら
If i > 40000 Then Exit Sub
にしてください。
７列を主体に繰り回し、行はそれについていく。
Ｓｈｅｅｔ２の出力行は繰り返し回数で捉えられる。
ーーー
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
k = 1
i = 0
While 1 = 1
For j = 1 To 12
i = i + 1
If i > 500 Then Exit Sub
sh2.Cells(k, j) = sh1.Cells(i, "D")
sh2.Cells(k, j + 12) = sh1.Cells(i, "E")
Next j
k = k + 1
Wend
End Sub

お礼

imogasiさん、ほかのみなさんとは
異なるアプローチ、ありがとうございました。
また、御礼が遅れて失礼いたしました。

40000行でも、使わせていただいたのですが、
結構な早さで処理できました。

コード自体も大変短く、完結ですね。
ありがとうございました。

回答No.5

yambejp

すみません。a()は単純にarrayの頭文字がaなので
使ってます。深い意味はありません。

さて＃２のバグの件、失礼しました。
エラーの原因はわかりました。
cellに対してSheets("hoge")が利いていないですね。
これも以下のようにoffsetでやるとよいかもしれません。
そうでなければcellをSheet("hoge").cellなど
明示すればよいでしょう。

offset自体はいわゆるオフセットをとるつまり
右や下にずれた値をとるときにつかいます。
いろいろテストしてみていただくとわかります。

ちなみにFORで使うカウンタはなるべくI～Nを使う
因習があります。(一説にはINTをもじって、
未定義でもI～Nを変数に使うとINT型になるから
とききます by fortran)
これは汎用的につかうのでループごとに変更する
必要はありません。配列もredimすると初期化される
ので、大きさが同じなら使いまわして問題ないでしょう。

以上をまとめるとこんな感じ。
ご不明の点はまたご質問ください。

max_col = 24
max_row = 2000

Dim a()
ReDim a(max_row - 1, max_col - 1)
For i = 0 To max_col - 1
For j = 0 To max_row - 1
a(j, i) = Sheets("Sheet1").Range("D1").Offset((i Mod 12) + 12 * j, i \ 12)
Next
Next

Set c = Sheets("Sheet3").Range("A1")
Range(c, c.Offset(max_row - 1, max_col - 1)).Value = a

ReDim a(max_row - 1, max_col - 1)
For i = 0 To max_col - 1
For j = 0 To max_row - 1
a(j, i) = Sheets("Sheet2").Range("D1").Offset((i Mod 12) + 12 * j, i \ 12)
Next
Next

Set c = Sheets("Sheet3").Range("Y1")
Range(c, c.Offset(max_row - 1, max_col - 1)).Value = a

補足

> cellに対してSheets("hoge")が利いていないですね。

文末のように本番環境に適用してみたのですがうまく動きません
（先の御礼に書いたとおり、a()は他のところで使っているので
重複してるといわれるのでarray1に改名しています）

プログラムでは、他にもごちゃごちゃした処理をして、
最後の方でこのマクロの出番があるのですが、

(1) マクロ全体を頭から実行するとSheet3に行列を入れ替えて貼り付け
られるのですが、転記元であるSheet1とSheet2のA列も貼り付けられて
しまい、意図したものと整形結果が異なっています。

(2) また、上記の「ごちゃごちゃした処理」を全部コメントにし、純粋に
本マクロだけを実行するとエラーなくマクロは実行されているようなの
ですが、Sheet3には何も貼り付けられません。

以上から推察されるのは、何か変数が上書きされているとかが
起こっているようですが・・

>カウンタはなるべくI～Nを使う
こちらの件は、とても勉強になりました。
PHPのプログラムを切り貼りしていて、iをカウンタとしたループ内で
iを使ったループを入れ子にしてしまい、それがバグであることに
なかなか気づかず、発見にえらい苦労した経験があったものですから、
初期化されることはなんとなく承知しているのですが、なんだか
重複させたくなかった次第です。

max_col = 24
max_row = 3500

Dim array1()
ReDim array1(max_row - 1, max_col - 1)
For i = 0 To max_col - 1
For j = 0 To max_row - 1
array1(j, i) = Sheets("Sheet1").Range("D1").Offset((i Mod 12) + 12 * j, i \ 12)
Next
Next

Set c = Sheets("Sheet3").Range("A1")
Range(c, c.Offset(max_row - 1, max_col - 1)).Value = a

ReDim array1(max_row - 1, max_col - 1)
For i = 0 To max_col - 1
For j = 0 To max_row - 1
array1(j, i) = Sheets("Sheet2").Range("D1").Offset((i Mod 12) + 12 * j, i \ 12)
Next
Next

Set c = Sheets("Sheet3").Range("Y1")
Range(c, c.Offset(max_row - 1, max_col - 1)).Value = a

回答No.4

hana-hana3

＞ScreenUpdating = False
とすると、目に見えなくなるのですね。
（そのほうが早いのかな？）

その通りです。
画面の更新を抑止するので、実行速度をアップ出来ます。

お礼

hana-hana3さん、つぶやきへのご回答ありがとうございました。

わたしが画面の更新が頻繁な既存のマクロに
設定してみたら、確かに体感できるレベルで
早くなりました。
今後とも使わせていただきます。

回答No.3

hana-hana3

＞こういう風にするのは難しいでしょうか。

すみませんm(__)m
読み間違えていたようです。
下記ではいかがですか？

Sub tst2()

Application.ScreenUpdating = False
Dim ct As Long
Dim ct2 As Long

ct2 = 1
For ct = 1 To 40000 Step 12
Sheets("Sheet1").Range(Cells(ct, "D"), Cells(ct + 11, "D")).Copy
Sheets("Sheet2").Cells(ct2, "A").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("Sheet1").Range(Cells(ct, "E"), Cells(ct + 11, "E")).Copy
Sheets("Sheet2").Cells(ct2, "A").Offset(, 12).PasteSpecial Paste:=xlPasteValues, Transpose:=True

ct2 = ct2 + 1
Next

End Sub

お礼

たびたびのレス、本当に恐縮です。

早速組み込んでみました。今後は１００％バッチリでした。

ScreenUpdating = False
とすると、目に見えなくなるのですね。
（そのほうが早いのかな？）

おかげさまで快適です。
＃２さんのものと合わせて都合がよさそうなものを検討し、
今後とも活用させていただきます。ありがとうございました。

回答No.1

hana-hana3

＞列ごと＆12行おきに「行列を入れ替えて貼り付け」みたいなことを・・・

してみました。（Transpose:=True）

Sub tst1()

Application.ScreenUpdating = False
Dim ct As Long
Dim ct2 As Long

ct2 = 1
For ct = 1 To 40000 Step 12
Sheets("Sheet1").Range(Cells(ct, "D"), Cells(ct + 11, "E")).Copy
Sheets("Sheet2").Cells(ct2, "A").PasteSpecial Paste:=xlPasteValues, Transpose:=True
ct2 = ct2 + 2
Next

End Sub

補足

hana-hana3さん、連日お世話になります。
大変ありがとうございます。試しましたところ、

【処理後】
D1　D2　D3　D4　D5　D6　D7　D8　D9　D10　D11　D12■ここで改行
E1　E2　E3　E4　E5　E6　E7　E8　E9　E10　E11　E12■ここで改行
D13　D14　D15　D16　D17　D18　D19　D20　D21　D22　D23　D24■ここで改行
E13　E14　E15　E16　E17　E18　E19　E20　E21　E22　E23　E24■ここで改行
D25　D26　D27　D28　D29　D30　D31　D32　D33　D34　D35　D36■ここで改行
E25　E26　E27　E28　E29　E30　E31　E32　E33　E34　E35　E36■ここで改行
：（略）

となってしまいますが、

【処理後】
D1　D2　D3　D4　D5　D6　D7　D8　D9　D10　D11　D12　E1　E2　E3　E4　E5　E6　E7　E8　E9　E10　E11　E12■ここで改行
D13　D14　D15　D16　D17　D18　D19　D20　D21　D22　D23　D24　E13　E14　E15　E16　E17　E18　E19　E20　E21　E22　E23　E24■ここで改行
D25　D26　D27　D28　D29　D30　D31　D32　D33　D34　D35　D36　E25　E26　E27　E28　E29　E30　E31　E32　E33　E34　E35　E36■ここで改行
：（略）

こういう風にするのは難しいでしょうか。