列と行の名前（重複あり）が交差するセルに、データを入力したい

同じ内容で何度も、まだ解決していないので、すみません。教えて下さい！
列と行の名前（同じ名前含む）が交差するセルに、データを入力したい。
1）表1、B列5行目以降の名前とD列2行目以降の列の名前が交差するセルに
表3、結果（やりたい結果）のように、日付と名前と数量のデータを入力したいので、
2）VBAプログラムを作成し実行するのですが、表2、結果となります。
【質問】
以下の①②が上手く行きませんので、どなたか教えて頂けないでしょうか！
VBA初心者ですので、宜しくお願いします。
又は、他の手法のプログラムで良い方法が有りましたら、ご指導お願いします。
①　行の名前が複数ある場合、すべての名前に入力したいが、１つの名前のみ入力となる。
　（列の名前は1つの名前のみです。）行の同じ名前が交差するセルの記述方法を教えて下さい。
②　行に名前（メロン）が有るのですが、列に名前が無い場合は、記入無しにしたいが、
　　入力してしまう。入力しない記述方法を教えて下さい。
③実際のデータでは、行の名前等は5/31まで、列の名前も他に追加ありますが、
　画像データは行/列とも、省略しています。

Sub Testクロス()
Dim i, k, TgRow, TgCol As Long
MaxRow = Cells(Rows.Count, 2).End(xlUp).Row '検索値最終行
MaxCol = Cells(2, Columns.Count).End(xlToLeft).Column 'シート「DATA」の最終列を取得
'データ削除
If MaxRow > 5 Then
Range(Cells(6, "D"), Cells(MaxRow, MaxCol + 3)).ClearContents
End If
For Each k In Range("B6:B" & MaxRow)
For i = 6 To MaxRow
If Cells(i, 2) = k Then
TgRow = i
Exit For
End If
Next i
For i = 4 To MaxCol
If Cells(2, i) = k Then
TgCol = i
Exit For
End If
Next i
Cells(TgRow, TgCol).Value = k.Offset(0, -1).Value
Cells(TgRow, TgCol).Offset(0, 3).Value = k.Value
Cells(TgRow, TgCol).Offset(0, 1).Value = k.Offset(0, 1).Value
Next k
End Sub

No.1 ベストアンサー 回答者： fujillin 回答日時： 2022/06/25 23:37

こんばんは

画像がよく見えないので、はっきりとはわかりませんけれど、こんなことでしょうか？

Sub Q13014030()
Dim rw As Long, rg As Range, f As Range
Set rg = Range(Cells(2, 4), Cells(2, Columns.Count).End(xlToLeft))

For rw = 6 To Cells(Rows.Count, 2).End(xlUp).Row
Cells(rw, 4).Resize(, rg.Count + 3).ClearContents
Set f = rg.Find(Cells(rw, 2).Value)
If Not f Is Nothing Then
Cells(rw, f.Column).Value = Cells(rw, 1).Value
Cells(rw, f.Column + 1).Value = Cells(rw, 3).Value
Cells(rw, f.Column + 3).Value = Cells(rw, 2).Value
End If
Next rw
End Sub

この回答へのお礼

ありがとうございました。
来週からの作業が捗ります。　又、プログラム勉強させて頂きます。

お礼日時：2022/06/26 00:24

No.2 回答者： Qchan1962 回答日時： 2022/06/26 00:00

こんばんは

①　Next i　の位置がおかしい
②　処理されないように分岐すれば良いかと　Next iの位置で解消できます

べたな処理で先ずはロジックを考えてみては？
一例
Sub Testクロス()
Dim i As Long, MaxRow As Long, MaxCol As Long
Dim k As Range
MaxRow = Cells(Rows.Count, 2).End(xlUp).Row '検索値最終行
MaxCol = Cells(2, Columns.Count).End(xlToLeft).Column 'シート「DATA」の最終列を取得
'データ削除
If MaxRow > 5 Then
Range(Cells(6, "D"), Cells(MaxRow, MaxCol + 3)).ClearContents
End If
For i = 4 To MaxCol Step 4 '結合セル
For Each k In Range("B6:B" & MaxRow)
If Cells(2, i) = k Then
With Cells(k.Row, i)
.Value = k.Offset(0, -1).Value
.Offset(0, 1).Value = k.Offset(0, 1).Value
.Offset(0, 3).Value = k.Value
End With
End If
Next k
Next i
End Sub