(VBA) 横並びを縦並びに

質問

kkkkkmさん、毎回アドバイスいただき感謝します。

以下のスレッドが元になります。
https://okwave.jp/qa/q10027270.html

なぜだか？私の質問スレッドが消えてしまいました。
途中で投げ出したような感じで気持ちが悪いので続けます。

以下は、最後のkkkkkmさんの回答への追加質問になります。

>LastRowNum2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
>の位置がソートの前のあたりに無いと1回目(実行前のsh2にデータが無い時LastRowNum2が1のままなので)ソートしてくれませんでした。

LastRowNum2は、ソートの時のソート範囲にしか利用しないので
おっしゃるようにソートの前で問題ないのですが
sh2にDATAが無い状態とは
マクロが実行されていない最初の状態又は
SH1にDATAが無い状態でマクロを実行した時だけだと思うのですが ？

一応、次回に備えてsh2のシート全体を初期化のため
sh2.Cells.ClearContents
を最初に追加しました。

>D列のソートでいいかどうか、利用者で変更してくれるといいですね。

今回はD列（項目）でソートしていますが
ソートのキーとしてA,B,C,Dの4つが考えられます。
それぞれ優先順位でD-A-B-C や A-B-C-D など色々組み合わせが考えられますが
これの組み合わせを網羅して利用者が選択できるようにするには
簡単では無いような気がします。
勉強のため少し考えてみますが、
考え方（ロジック）や使用すべき関数などを紹介下さい。

>Resize
確かにresizeを使用したほうが分かりやすいですね。

'-------------------------------------
と「ここまで」記載した時点でスレッドが消滅してしまいました。

以下が現在のコード

Option Explicit

Sub Macro1()

Dim sh1 As Worksheet, sh2 As Worksheet
Dim LastRowNum As Long, LastRowNum2 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")

LastRowNum = sh1.Cells(Rows.Count, 1).End(xlUp).Row

'書き出しシート(sh2)の初期化
sh2.Cells.ClearContents

'見出し行
sh2.Range(sh2.Cells(1, "A"), sh2.Cells(1, "D")).Value = sh1.Range(sh1.Cells(1, "A"), sh1.Cells(1, "D")).Value

'同一（ID,名前)
sh2.Range(sh2.Cells(2, "A"), sh2.Cells(LastRowNum, "B")).Value = sh1.Range(sh1.Cells(2, "A"), sh1.Cells(LastRowNum, "B")).Value
sh2.Range(sh2.Cells(LastRowNum + 1, "A"), sh2.Cells(2 * LastRowNum - 1, "B")).Value = sh1.Range(sh1.Cells(2, "A"), sh1.Cells(LastRowNum, "B")).Value

'手術日,項目
sh2.Range(sh2.Cells(2, "C"), sh2.Cells(LastRowNum, "D")).Value = sh1.Range(sh1.Cells(2, "C"), sh1.Cells(LastRowNum, "D")).Value
'手術日,項目(配置換え)
sh2.Range(sh2.Cells(LastRowNum + 1, "C"), sh2.Cells(2 * LastRowNum - 1, "D")).Value = sh1.Range(sh1.Cells(2, "E"), sh1.Cells(LastRowNum, "F")).Value

LastRowNum2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row

'ソート
sh2.Range(sh2.Cells(2, "A"), sh2.Cells(LastRowNum2, "D")).Sort key1:=sh2.Range("D1"), order1:=xlAscending, Header:=xlYes

Set sh1 = Nothing
Set sh2 = Nothing

End Sub

回答No.2

kkkkkm · ベストアンサー

削除された質問の方で回答したのですが、同じことを書くのも疲れるのでかいつまんで

LastRowNum2の件は
前回と今回の最終行が同じとは限らないので初期化はいいと思います。

ソートについては、ユーザーフォームで対応することが考えられますが、毎回違うソートをするとも思えないので、最初に利用者に聞いてそれを固定すればいいと思います。利用者で変更というのはコードを書き替えてくれたらいいですねという意味です。

回答No.3

imogasi

前質問で、締め切り勅語に回答ボタンを押して、無効になった。
今回の名指しの回答者ではないが、簡単と思うので、コードを挙げる。
＝＝
例データ　Sheet1　A2:H4
123 藤田 2022/4/4 A 2022/5/9 B 2022/6/9 F
689 斎藤 2022/3/8 C 2022/8/5 D
168 田中 2022/5/5 E 2022/8/6 F
このように同性格のデータ例が２つ以上ないか書いてないところが、経験不足を思う画像では、そういう点が、分からず、質問として不完全。普通２組で終わらないのではないか。
＝＝
標準モジュールに
Sub test01()
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
sh2.Columns(3).NumberFormat = "yyyy/mm/dd"
k = 2
lr = Range("A10000").End(xlUp).Row
MsgBox lr
For i = 2 To lr
rc = Cells(i, 1000).End(xlToLeft).Column '最右列検知
MsgBox rc
For j = 3 To rc Step 2
sh2.Cells(k, "A") = Cells(i, "A")
sh2.Cells(k, "B") = Cells(i, "B")
sh2.Cells(k, "C") = Cells(i, j)
sh2.Cells(k, "D") = Cells(i, j + 1)
k = k + 1
Next j
Next i
End Sub
＝＝
結果　Sheet2　A2:D8
123 藤田 2022/04/04 A
123 藤田 2022/05/09 B
123 藤田 2022/06/09 F
689 斎藤 2022/03/08 C
689 斎藤 2022/08/05 D
168 田中 2022/05/05 E
168 田中 2022/08/06 F
＝＝
他の方法として、紙ベースで、表データができている場合切り貼りする要領で、手動で下の部分にコピペして、全体を番号＋氏名でソートしたら仕舞ではないか？
その時、まずA,B列の番号＋氏名を全行をコピーし、各データ列に挿入する（空白列２列作り、そこに番号＋氏名をずれないように張り付ける。）
其の後E,F,G,H列をコピーして、A-D列の最終行の直下部へ貼りつける。これを繰り返す。
VBA云々を、色々言うより、これが一番早いよ。

お礼

kkkkkmさん、回答ありがとうございます。

削除理由は、「スレ主さんは、----- 」が以下に該当する為とメイルがありました。

他の会員や投稿について言及している内容が含まれていたと判断したため。
※具体的に対象が特定されていない場合や、単なる興味のみで他意が無い場合でも、
該当する会員の方が不快な思いをしたり、Ｑ＆Ａの趣旨にそぐわない議論に発展するおそれがあるため、ご遠慮いただいております。

今回の件で私も対応が判ったので次回同じことが無いように書き込みに注意をしたいと思います。

>ソートについては、----- 利用者で変更というのはコードを書き替えてくれたらいいですねという意味です。

回答の意味理解しました。

imogasiさん、ロジックの回答ありがとうございます。

回答No.1

kkkkkm

メール届いてないですか

■対応理由
他の会員や投稿について言及している内容が含まれていたと判断したため。

で質問が削除されましたので今回も削除されると思います。