Va la macro entonces:
Sub Concatenar_Datos()
'---
' Por.Dante Amor
'---
Application.ScreenUpdating = False
cond = "n"
'
Set h = ActiveSheet
Set r = h.Columns("C")
'Limpiar
Set b = r.Find(cond, lookat:=xlWhole)
If Not b Is Nothing Then
celda = b.Address
Do
b.Offset(0, 1).Value = ""
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
End If
'
Set b = r.Find(cond, lookat:=xlWhole)
If Not b Is Nothing Then
celda = b.Address
ini = b.Row
Do
'detalle
fila = b.Row + 1
cad = ""
Do While h.Cells(fila, "D") <> ""
cad = cad & Cells(fila, "D") & ", "
fila = fila + 1
Loop
If cad <> "" Then
b.Offset(0, 1) = Left(cad, Len(cad) - 2)
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
End If
'
u = h.Range("D" & Rows.Count).End(xlUp).Row
On Error Resume Next
With Range("D" & ini & ":D" & u)
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[1]C"
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
Application.ScreenUpdating = True
Application.CutCopyMode = True
Range("C2").Select
MsgBox "Fin"
End Sub
sal u dos