Sub test()
Dim D As Object, C As Range,firstrow&
Set D = CreateObject("scripting.dictionary")
For Each C In Range("D1", Cells(Rows.Count, "D").End(xlUp)).Cells
If C.MergeCells = True And Not D.exists(C.MergeArea.Address) Then
If firstrow = 0 Then firstrow = C.Row
D(C.MergeArea.Address) = C.Value: C.MergeCells = False: C = ""
End If
Next
Cells(firstrow, "D").Resize(D.Count, 1) = Application.Transpose(D.Items)
End Sub