Excel 並び替え

上の写真を下の写真のように並び替えたいです

今は1行づつ、コピーして縦に並び替えて貼り付けてるのですが、良い方法はないでしょうか？

No.7 回答者： よろずやkinchan 回答日時： 2019/12/21 12:07

No.4です。

1か所ミスがありましたので再掲します。

Option Explicit
Sub Sample()
　　Const TopRow1 = 3, LeftCol1 = 2, TopRow2 = 1, LeftCol2 = 1
　　Dim Row1 As Long, Col1 As Long, Row2 As Long
　　Dim Sh1 As Worksheet, Sh2 As Worksheet
　　Set Sh1 = Worksheets("Sheet1")
　　Set Sh2 = Worksheets("Sheet2")
　　Row2 = TopRow2
　　For Row1 = TopRow1 To Sh1.Cells(TopRow1, LeftCol1).End(xlDown).Row
　　　　Col1 = LeftCol1 + 1
　　　　Do Until IsEmpty(Sh1.Cells(Row1, Col1).Value)
　　　　　　Sh2.Cells(Row2, LeftCol2).Value = Sh1.Cells(Row1, LeftCol1).Value
　　　　　　Sh2.Cells(Row2, LeftCol2 + 1).Value = Sh1.Cells(Row1, Col1).Value
　　　　　　Col1 = Col1 + 1
　　　　　　Row2 = Row2 + 1
　　　　Loop
　　Next Row1
End Sub

No.6 回答者： GOMΛFU 回答日時： 2019/12/21 11:24

列でコピーして他のシートに貼り付ける。

後はソートして空白行を削除する。

No.5 回答者： mike_g 回答日時： 2019/12/21 11:00

このような不鮮明な画像の添付はご遠慮ください。

No.4 回答者： よろずやkinchan 回答日時： 2019/12/21 10:14

No.2です。

1か所ミスがありましたので再掲します。

Option Explicit
Sub Sample()
　　Const TopRow1 = 3, LeftCol1 = 2, TopRow2 = 1, LeftCol2 = 1
　　Dim Row1 As Long, Col1 As Long, Row2 As Long
　　Dim Sh1 As Worksheet, Sh2 As Worksheet
　　Set Sh1 = Worksheets("Sheet1")
　　Set Sh2 = Worksheets("Sheet2")
　　Row2 = TopRow2
　　For Row1 = TopRow1 To Sh1.Cells(TopRow1, LeftCol1).End(xlDown).Row
　　　　Col1 = LeftCol1 + 1
　　　　Do Until IsEmpty(Sh1.Cells(Row1, Col1).Value)
　　　　　　Sh2.Cells(Row2, LeftCol2).Value = Sh1.Cells(Row1, LeftCol1).Value
　　　　　　Sh2.Cells(Row2, LeftCol2 + 1).Value = Sh1.Cells(Row1, Col1).Value
　　　　　　Col1 = Col1 + 1
　　　　Loop
　　Next Row1
End Sub

No.3 回答者： tom04 回答日時： 2019/12/21 10:05

こんにちは！

画像が小さくて詳細がよく判らないのですが・・・
こちらで勝手に解釈しています。

VBAでの一例です。
元データはSheet1にあり、Sheet2に表示するとします。
標準モジュールにしてください。

Sub Sample1()
　Dim i As Long, lastCol As Long
　Dim myRow As Long
　Dim wS As Worksheet

　　Set wS = Worksheets("Sheet2")
　　　wS.Range("A:B").ClearContents
　　　myRow = 1
　　　　With Worksheets("Sheet1")
　　　　　For i = 3 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　lastCol = .Cells(i, Columns.Count).End(xlToLeft).Column
　　　　　　　If lastCol > 1 Then
　　　　　　　　wS.Cells(myRow, "A").Resize(lastCol - 1).Value = .Cells(i, "A")
　　　　　　　　wS.Cells(myRow, "B").Resize(lastCol - 1).Value = _
　　　　　　　　　Application.Transpose(.Cells(i, "B").Resize(, lastCol - 1).Value)
　　　　　　　End If
　　　　　　　　myRow = wS.Cells(Rows.Count, "A").End(xlUp).Row + 1
　　　　　Next i
　　　　End With
　　　　　wS.Activate
　　　　　MsgBox "完了"
End Sub

※　Sheet2のB列表示形式は好みの表示形式にしておいてください。m(_ _)m

No.2 回答者： よろずやkinchan 回答日時： 2019/12/21 09:56

Option Explicit

Sub Sample()
Const TopRow1 = 3, LeftCol1 = 2, TopRow2 = 1, LeftCol2 = 1
Dim Row1 As Long, Col1 As Long, Row2 As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
Row2 = TopRow2
For Row1 = TopRow1 To Sh1.Cells(TopRow1, LeftCol1).End(xlDown).Row
Col1 = LeftCol + 1
Do Until IsEmpty(Sh1.Cells(Row1, Col1).Value)
Sh2.Cells(Row2, LeftCol2).Value = Sh1.Cells(Row1, LeftCol1).Value
Sh2.Cells(Row2, LeftCol2 + 1).Value = Sh1.Cells(Row1, Col1).Value
Col1 = Col1 + 1
Loop
Next Row1
End Sub

No.1 回答者： 銀鱗 回答日時： 2019/12/21 08:08

それで処理できるならそれで良いんじゃないのかな。

5000行あっても2時間もあれば終わる作業だよね。

並び替えのルールなど示されていませんので、残念ですが1行ずつ処理することをお勧めするしかありません。
並び替えのルール次第で処理方法が変わるんですよ。

自分なら簡易的に数式を作って並べ替えてしまうかな。
その数式の作り方は ”並べ方のルール” に従って作ることになるんだ。
（縦横に並べ替えるだけなら、OFFSET関数とROW関数で行番号を取得してそれをINT、MOD関数に入れて参照するだけ）
でもって結果が表示されているセル（列）をコピーして、数式を含まない「値」として貼り付けた後に空白行を削除するなど後処理をする。
最後に作った数式を削除ってこともする。（並べ替えた後は不要なんだろ？）
以後は縦に並ぶようにデータを入力しよう。

・・・
そんなわけで、自分で処理するための知識を身に付けたいということであれば協力しますけど、
他人に代わりにやってもらう事を望んでいるのでしたら、
この手の作業を請け負ってくれる業者さんを探すことをお勧めします。