表 集計の表示を変える マクロ エクセル

質問

添付の画像のように左の表から右の表になるように集計の表示を変えたいです。
実際には左表の縦方向に100行ぐらいあります。

一度こちらで質問したらシンプルな関数を教えていただいたのですが、自分がカスタマイズしやすいように、マクロで以下の方法でやりたいです。
１．黄色の範囲をタテヨコ変えてコピペ
２．緑の範囲、青の範囲も同様
３．いいいの行も上記同様
これを繰り返す。

タテヨコを変えてコピペをやるのはマクロ記録でできるのですが、
2行おきにそれを繰り返す記述が分かりませんので教えてください。

回答No.3

imogasi

＃２です。
データ例は前質問の私の回答を見てください。
今回はＳｈｅｅｔ４に結果を出します。
コードは
Sub test02()
Set sh1 = Worksheets("Sheet1")
Set sh4 = Worksheets("Sheet4")
lr = sh1.Range("B10000").End(xlUp).Row 'B列データ最終行取得。Ａ列では本ケースでは不可
k = 3
For i = 2 To lr Step 3
sh1.Range(sh1.Cells(i, "C"), sh1.Cells(i + 2, "C")).Copy
sh4.Cells(k, 2).PasteSpecial xlPasteAll, Transpose:=True
'--
sh1.Range(sh1.Cells(i, "D"), sh1.Cells(i + 2, "D")).Copy
sh4.Cells(k, 5).PasteSpecial xlPasteAll, Transpose:=True
'---
sh1.Range(sh1.Cells(i, "E"), sh1.Cells(i + 2, "E")).Copy
sh4.Cells(k, 8).PasteSpecial xlPasteAll, Transpose:=True
k = k + 1
Next i
End Sub
Ｔｒａｎｓｐｏｓｅを使ってます。
コード行数を少なくすることを第Iに考えました。
ーーー
結果　数字部分
Ｂ３：Ｊ６
1 2 3 11 12 13 21 22 23
4 5 6 14 15 16 24 25 26
7 8 9 17 18 19 27 28 29
10 11 12 20 21 22 30 31 32
他の、見出し部分行の文言（グループとランク）ｈｓコピペとＡ列（「あああ」など、関数で出した）は、省略しています。前回答を見てください。

お礼

こちらもできること確認しました。ありがとうございました。

回答No.2

imogasi

前の質問にＶＢＡで回答しましたが見てくれましたか。
そして前の質問を締め切ってください。２重質問状態になるので。マナー違反。
本質問の添付画像の色の付いた部分を横１行に（ＶＢＡで）する方法もありますが、次の3行おきのセル範囲の「カタマリ」を、行をずらして処理し、結果を置くところも１行ずらしていかなければならず、慣れない人にはむつかしい。
まあ私の前回答のように、述べてやるより、考えやすいかもしれない。
２重３重ループにする方法もありますが。

回答No.1

SI299792

２本作りました。
＞タテヨコを変えてコピペをやる
と書いてあったので、その通りに作ってみたのですが、時間がかかります。(Macro1)
直接セルに入れるなら、すぐに済みます。(Macro2)
なお、グループとランクの所は、作っていません。
'
Option Explicit
'
Sub Macro1()
'
　　Dim iy As Integer
　　Dim ix As Integer
　　Dim oy As Integer
　　Dim ox As Integer
'
　　Application.ScreenUpdating = False
'
　　For iy = 2 To [B2].End(xlDown).Row Step 3
　　　　oy = iy \ 3 + 4
　　　　Cells(oy, "G") = Cells(iy, "A")
'
　　　　For ix = 3 To 5
　　　　　　ox = ix * 3 - 1
　　　　　　Cells(iy, ix).Resize(3, 1).Copy
　　　　　　Cells(oy, ox).Select
　　　　　　Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　　　　　False, Transpose:=True
　　　　Next ix
　　Next iy
End Sub
'
Sub Macro2()
'
　　Dim iy As Integer
　　Dim ix As Integer
　　Dim oy As Integer
　　Dim ox As Integer
　　Dim id As Integer
'
　　Application.ScreenUpdating = False
　　For iy = 2 To [B2].End(xlDown).Row Step 3
　　　　oy = iy \ 3 + 4
　　　　Cells(oy, "G") = Cells(iy, "A")
'
　　　　For ix = 3 To 5
　　　　　　ox = ix * 3 - 1

　　　　　　For id = 0 To 2
　　　　　　　　Cells(oy, ox + id) = Cells(iy + id, ix)
　　　　　　Next id
　　　　Next ix
　　Next iy
'
　　With Range("G2:P" & oy)
　　　　.Borders(xlEdgeLeft).LineStyle = xlContinuous
　　　　.Borders(xlEdgeTop).LineStyle = xlContinuous
　　　　.Borders(xlEdgeBottom).LineStyle = xlContinuous
　　　　.Borders(xlEdgeRight).LineStyle = xlContinuous
　　　　.Borders(xlInsideVertical).LineStyle = xlContinuous
　　　　.Borders(xlInsideHorizontal).LineStyle = xlContinuous
　　End With
End Sub

お礼

どちらもできました。ありがとうございました！