行列入れ替えて貼り付ける方法を教えてください。

質問

シート1のC3:AF4にあるデータ(右に30個あるデータ)を、シート2のE列の
最終行の1個下から「形式を選択して貼り付け」の「行列を入れ替える」
で、下に30個貼り付けるマクロを書きたいのですが、どうしたらいい
でしょうか？

最終行の一個下というところと、行列入れ替えて貼り付けというのが
わからなくて…。

また、C3:AF4のE列への貼り付けが終わったらC7:AF8をB列に貼り付け、
C11:AF12をH列に貼り付けたいのです。

画像を添付します。

マクロの自動保存だと失敗してしまったので、これをどう修正したら
いいか教えてほしいです。

Sub Macro2()
'
' Macro2 Macro
'

'
Range("C7:AF8").Select
Selection.Copy
Sheets("Sheet2").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("E2").Select
Sheets("Sheet1").Select
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("C3:AF4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H2").Select
Sheets("Sheet1").Select
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("C11:AF12").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B1").Select
End Sub

よろしくお願いします。

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.2

KURUMITO · ベストアンサー

次のようなマクロでできると思いますね。
Sub 行列入れ替え()
Dim m As Integer
m = Sheets("Sheet2").Range("E65536").End(xlUp).Row + 2
Sheets("Sheet1").Activate
Sheets("Sheet1").Range("C3:E5").Select
Selection.Copy
Sheets("Sheet2").Activate
Range("E" & m).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("E" & m).Select
End Sub

お礼

スゴイですね！
完璧です！
とても助かりました！
ありがとうございました！

回答No.1

Trick--o--

シート2のE列の最終行の1個下

　Worksheets("シート2").Cells(Worksheets("シート2").Range("E65536").End(xlUp).Row + 1 , 5)

説明
Worksheets("シート2")
　シート2の
.Range("E65536")
　E列の最下段（Excel2003以前の場合）から
.End(xlUp)
　上方向にデータがあるセル（Ctrl+↑ に相当する動作）
.Row
　の、行番号

これで貼り付ける位置は特定できたので、
コピーと貼り付けのコマンドを書けばおｋ

お礼

ありがとうございます！
稼動しました！