マクロについてのご相談です。

教えて頂ければと投稿しました。
・・C・・D・・E・・F・・G・・H
3・abc･･･15･･･20･･･････････････
4・def･･･10･･･10･･abc･･･15･･･10
5・ghi････5････5･････････････････
6・jkl････8････30･･ghi････1････5
以下続く

このような表があった場合に、C行とF行が同じ値のものを横並べにして、D行、E行はそのまま横並び、G行、H行もそのまま横並びにして表を完成させたいです。このようなマクロをご教示して頂きたくよろしくお願いいたします。

完成型
・・C・・D・・E・・F・・G・・H
3・abc･･･15･･･20･･abc･･･15･･･10
4・def･･･10･･･10･･･････････････
5・ghi････5････5･･･ghi････1････5
6・jkl････8････30････････････････
以下続く

No.1 ベストアンサー 回答者： tatsumaru77 回答日時： 2023/10/14 16:57

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

Option Explicit
Public Sub 並べ替え()
Dim dicT As Object
Dim dicR As Object
Dim ws As Worksheet
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim arr As Variant
Dim wrow As Long
Dim srow As Long
Dim key As Variant
Set dicT = CreateObject("Scripting.Dictionary")
Set dicR = CreateObject("Scripting.Dictionary")
Set ws = ActiveSheet
maxrow1 = ws.Cells(Rows.Count, "C").End(xlUp).Row
maxrow2 = ws.Cells(Rows.Count, "F").End(xlUp).Row
arr = ws.Range("F1:H" & maxrow2)
For wrow = 3 To maxrow2
key = ws.Cells(wrow, "F").Value
If key <> "" Then
If dicT.exists(key) = False Then
dicT(key) = wrow
End If
End If
Next
For wrow = 3 To maxrow1
key = ws.Cells(wrow, "C").Value
If dicT.exists(key) = True Then
srow = dicT(key)
ws.Cells(wrow, "F").Value = key
ws.Cells(wrow, "G").Value = arr(srow, 2)
ws.Cells(wrow, "H").Value = arr(srow, 2)
dicR(wrow) = True
If dicR.exists(srow) = False Then
ws.Cells(srow, "F").Resize(1, 3).ClearContents
End If
End If
Next
MsgBox ("完了")
End Sub