Excel VBA 複数列を行に変換して整理して並べたい

御質問させてください。
Excelバージョン：2013

1行目から17行目の表を20行目以降のような形で並び替えたいです。
中身の情報は都度変わるため、変化しても対応できるよな並び替え方法はないでしょうか？
本来は17行目以降にも情報があります。
VBAもしくは関数で対応させたいです。

しばらく考えていたのですが、思いつかずお知恵をお借りすることにしました。
2019版　or 365 でPower Queryでの変換も視野に入れております。

質問者からの補足コメント

• 拡大版1

  
    補足日時：2022/02/17 21:55

• 拡大版2

  
    補足日時：2022/02/17 21:55

• tatsumaru77　様
  回答ありがとうございます。
  
  １．拡大版１の図の１行目の見出しですが、
  A列～Q列まで、何と書いてありますか。各列ごとに提示してください。
  【回答】
  A:部番,B:部品色,C:納期,D:時間,E:総数量,F:個口,G:空白,H:予定数,I:連番,J:個口,K:空白
  ,L:予定数,M:連番,N:個口,O:空白,P:予定数,Q:連番
  
  ２．拡大版２の図についてです。
  セルの具体的な位置がわかりません。
  ①一番左の列はA列ですか。
  【回答】　A列です
  ②部番の見出しがあるセルは１列目ですか
  【回答】　１列目です
  
  ３．拡大版１のシートのシート名は何でしょうか。
  【回答】　Sheet1　です
  ４．拡大版２のシートのシート名は何でしょうか。
  【回答】　Sheet2　です
  
  宜しくお願い致します。
  以上

  No.2の回答に寄せられた補足コメントです。 補足日時：2022/02/18 11:01

No.8 ベストアンサー 回答者： fujillin 回答日時： 2022/02/18 14:46

No5です。

No5には、ミスがありました。すみません。
以下、訂正しておきます。（No5は無視してください）

Sub Q12810913()
Dim DR As Range, v
Dim rw As Long, col As Long

Const SourceRange = "A1:Q17" '←元の表の範囲
Const DestRange = "A21" '←出力先セル位置（左上セル）
Set DR = Range(DestRange).Resize(1, 10)

With Range(SourceRange)
For rw = 2 To .Rows.Count
If .Cells(rw, 1) <> "" And .Cells(rw + 1, 1) <> "" Then
　DR(1).Value = .Cells(rw, 1).Value
　DR(2).Resize(, 2).Value = .Cells(rw + 1, 1).Resize(, 2).Value
　DR(4).Value = .Cells(rw, 3).Value
　v = DR(1).Resize(, 6).Value
End If
If .Cells(rw, 4) <> "" Then
　v(1, 5) = .Cells(rw, 4).Value
　v(1, 6) = .Cells(rw, 5).Value
End If

For col = 6 To .Columns.Count Step 4
If WorksheetFunction.CountBlank(.Cells(rw, col).Resize(, 4)) < 4 Then
　DR(1).Resize(, 6).Value = v
　DR(7).Resize(, 4).Value = .Cells(rw, col).Resize(, 4).Value
　Set DR = DR.Offset(1)
End If
Next col
Next rw
End With

End Sub

この回答へのお礼

tatsumaru77　様
御回答ありがとうございます。

承知致しました。
ご丁寧にありがとうございます。

お礼日時：2022/02/18 14:56

No.7 回答者： めぐみん_ 回答日時： 2022/02/18 14:20

拡大版１の中身に変動があると言うのはわかりましたが、拡大版２については１が校正され別のデータが打ち込まれたとした時、過去に纏めたデータに対し『上書き』ｏｒ『蓄積』のどちらなのでしょう？

まさか拡大版１がドンドン書き足されると言う訳ではないと感じましたので。

とは言えあちらでも回答も出てるようですね。

この回答へのお礼

めぐみん_　様
御回答ありがとうございます。

『上書き』タイプになりますね。
一度表示データを削除してから新たにデータが表示されるといった形を考えております。

お礼日時：2022/02/18 14:55

No.6 回答者： tatsumaru77 回答日時： 2022/02/18 13:18

以下のマクロを標準モジュールに登録してください。

Shee2の2行目以降を設定します。1行目は設定しません。
各列の書式設定はあなたのほうで適切に行ってください。
特に時刻、総数量、予定数などです。
---------------------------------------------
Option Explicit
Sub 複数列転記()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim lastRow As Long 'Sheet1 最終行
Dim row1 As Long 'Sheet1 処理行
Dim row2 As Long 'Sheet2 処理行
Dim wcol As Long 'Sheet2 処理列
Dim Pno1 As String '部番１
Dim Pno2 As String '部番２
Dim Pcolor As String '色
Dim Ddate As Variant '納期
Dim Dtime As Variant '時間
Dim Total As Variant '総数量
Dim mode As Long 'モード 0:部番待ち 1:各個口処理中
Dim i As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
'Sheet1の最終行取得
lastRow = sh1.Cells(1, 1).SpecialCells(xlLastCell).row
sh2.Rows("2:" & Rows.Count).ClearContents 'Sheet2をクリア
mode = 0
row2 = 2
For row1 = 2 To lastRow
If mode = 0 Then
If sh1.Cells(row1, "A").Value = "" Then GoTo NEXT99:
Ddate = sh1.Cells(row1, "C").Value '納期
Pno1 = sh1.Cells(row1, "A").Value '部番１
Pno2 = sh1.Cells(row1 + 1, "A").Value '部番２
Pcolor = sh1.Cells(row1 + 1, "B").Value '部品色
Dtime = sh1.Cells(row1 + 1, "D").Value '納期
Total = sh1.Cells(row1 + 1, "E").Value '総数量
If Ddate = "" Then
MsgBox (row1 & "行目の納期が空白")
Exit Sub
End If
If Pno2 = "" Then
MsgBox (row1 + 1 & "行目の部番が空白")
Exit Sub
End If
If Pcolor = "" Then
MsgBox (row1 + 1 & "行目の部品色が空白")
Exit Sub
End If
If Dtime = "" Then
MsgBox (row1 + 1 & "行目の時間が空白")
Exit Sub
End If
If Total = "" Then
MsgBox (row1 + 1 & "行目の総数量が空白")
Exit Sub
End If
'モードを変更し、次の行へ
mode = 1
GoTo NEXT99
End If
If mode = 1 Then
If sh1.Cells(row1, "F").Value = "" Then
'当該部番は終了と判定し、次の部番の出現を待つ
mode = 0
GoTo NEXT99
End If
'時刻と総数量が切り代わりを反映
If sh1.Cells(row1, "D").Value <> "" Then
Dtime = sh1.Cells(row1, "D").Value
Total = sh1.Cells(row1, "E").Value
End If
'個口処理を３回繰り返す
For i = 0 To 2
wcol = 6 + i * 4
If sh1.Cells(row1, wcol).Value = "" Then Exit For
sh2.Cells(row2, "A").Value = Pno1 '部番1
sh2.Cells(row2, "B").Value = Pno2 '部番2
sh2.Cells(row2, "C").Value = Pcolor '部品色
sh2.Cells(row2, "D").Value = Ddate '納期注番
sh2.Cells(row2, "E").Value = Dtime '時刻
sh2.Cells(row2, "F").Value = Total '総数量
sh2.Cells(row2, "G").Value = sh1.Cells(row1, wcol).Value '個口
sh2.Cells(row2, "H").Value = sh1.Cells(row1, wcol + 1).Value '空欄
sh2.Cells(row2, "I").Value = sh1.Cells(row1, wcol + 2).Value '予定数
sh2.Cells(row2, "J").Value = sh1.Cells(row1, wcol + 3).Value '連番
row2 = row2 + 1
Next
End If
NEXT99:
Next
MsgBox ("完了")
End Sub

この回答へのお礼

tatsumaru77　様
御回答ありがとうございます。

VBAに関して記述ありがとうございます。
後程検証させて頂きます。
先ずはお礼申し上げます

お礼日時：2022/02/18 14:17

No.5 回答者： fujillin 回答日時： 2022/02/18 11:23

こんにちは

関数でも不可能ではないと思いますが、相当に面倒なので、VBAにしてみました。
画像が良く見えないのと、変換のルールの説明がないので、勝手に解釈しています。

※ ご提示の元の表が記載ルールに合致しているものと仮定して、チェックは一切省いています。
※ おかしなデータが紛れ込む可能性がある場合は、チェックを追加するようにしてください。
※ 私の解釈がおかしなせいか、ご提示の結果とは最後の8行分の「時間」の表示が異なります。
　（どういうルールなのか理解できないので、そのままにしてあります）

以下は、とりあえず質問文に添付の表のままを対象とするようにしてありますが、
　・対象の表の範囲
　・出力先の位置
を変えれば、その内容に従って処理します。

ご参考にでもなれば。

Sub Q12810913()
Dim DR As Range, v
Dim rw As Long, col As Long

Const SourceRange = "A1:Q17" '←元の表の範囲
Const DestRange = "A21" '←出力先セル位置（左上セル）
Set DR = Range(DestRange).Resize(1, 10)

With Range(SourceRange)
For rw = 2 To .Rows.Count
If .Cells(rw, 1) <> "" And .Cells(rw + 1, 1) <> "" Then
　DR(1).Value = .Cells(rw, 1).Value
　DR(2).Resize(, 2).Value = .Cells(rw + 1, 1).Resize(, 2).Value
　DR(4).Value = .Cells(rw, 3).Value
End If
If .Cells(rw, 4) <> "" Then
　DR(5).Resize(, 2).Value = .Cells(rw, 4).Resize(, 2).Value
　v = DR(1).Resize(, 6).Value
End If

For col = 6 To .Columns.Count Step 4
If WorksheetFunction.CountBlank(.Cells(rw, col).Resize(, 4)) < 4 Then
　DR(1).Resize(, 6).Value = v
　DR(7).Resize(, 4).Value = .Cells(rw, col).Resize(, 4).Value
　Set DR = DR.Offset(1)
End If
Next col
Next rw
End With
End Sub

この回答へのお礼

fujillin　様
御回答ありがとうございます。

最後の8行分の「時間」の表示ですが、私の記入ミスでした。
申し訳ございません。
正しくは　12：00　です。　

VBAに関して記述ありがとうございます。
後程検証させて頂きます。
先ずはお礼申し上げます

お礼日時：2022/02/18 11:38

No.4 回答者： めぐみん_ 回答日時： 2022/02/18 10:39

No.1です。

ちなみにですが『部番』１組に対し『納期』の値数が１を超える事はあるのでしょうか？
多分可視セルのコピペを繰り返すってベタな方法なら可能でしょう。
ただ実際のデータ数が多くて速度重視ってなると、配列化は厳しそうに感じますし。。。
あと隠れてる数式の有無により上記案はボツリます。

この回答へのお礼

めぐみん_様
ご質問ありがとうございます。

ちなみにですが『部番』１組に対し『納期』の値数が１を超える事はあるのでしょうか？
【回答】値数は1っだけです。

お礼日時：2022/02/18 11:04

No.3 回答者： めぐみん_ 回答日時： 2022/02/18 10:11

#2様。

Ａ～Ｑ列って拡大版の方で読み取れると思えます（老眼ジジィですが）。
『総数量』～『連番』をＦ列以降繰り返しているのでしょう。
なので５列１組と思われます。（老眼なので違ったらごめんなさい。）

あとはどこで最終行を取得可能か次第でしょうか？
シート名は任意で修正してもらいあとは見かけ上同じような物は作れるでしょうけど、スマホでＶＢＡをデバッグなし且つコードの綴りミスなしとは
ちょっと厳しいので応援しております。

ＰＳ．
画像拡大については運営側に要望は出しております。
一応その方向で検討はして貰えそうですが、いつ対応できるかは今の状況では厳しいかもですね。

No.2 回答者： tatsumaru77 回答日時： 2022/02/18 09:17

補足要求です。

１．拡大版１の図の１行目の見出しですが、
A列～Q列まで、何と書いてありますか。各列ごとに提示してください。

２．拡大版２の図についてです。
セルの具体的な位置がわかりません。
①一番左の列はA列ですか。
②部番の見出しがあるセルは１列目ですか。

３．拡大版１のシートのシート名は何でしょうか。
４．拡大版２のシートのシート名は何でしょうか。

この回答へのお礼

tatsumaru77　様
ご質問ありがとうございます。

補足不足で申し訳ございません。
補足回答させていただきました。

宜しくお願い致します。

お礼日時：2022/02/18 11:06

No.1 回答者： めぐみん_ 回答日時： 2022/02/18 07:06

画像が不鮮明なのでわからない

拡大できる知恵袋とかが宜しいのではないかな？

パワクエはそんな空白セルばかりのものは扱えない気がします
ただし未経験です

あとは画像任せではなく、求める仕様を箇条書きでも書いて説明する事かな？
各列の行関係は左側を基準としたら、すべて同じになるのかどうか
その他としては順列？みたいに、どこかの列以降は纒められていてそれを総組み合わせする感じに思えるけど、そこがよく見えないし

この回答へのお礼

御回答ありがとうございます。
アドバイス頂いた通り、知恵袋での御相談もしてみようと思います。
詳細も出来るだけ記述してみようと思います。

お礼日時：2022/02/18 08:23