Sub Reformat()
Application.ScreenUpdating = False
Dim i As Long, j As Long
With ActiveSheet
  .Cells.UnMerge
  For i = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Row
  If .Cells(i, 1).Value <> "" Then
    j = i
  Else
    If Trim(.Cells(j, 3).Value) <> "" Then
      .Cells(j, 3).Value = .Cells(j, 3).Value & Chr(10) & .Cells(i, 3).Value
      .Cells(i, 3).Value = ""
    End If
  End If
  Next
  For i = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
    If .Cells(i, 1).Value = "" Then .Cells(i, 1).EntireRow.Delete
  Next
End With
Application.ScreenUpdating = True
End Sub