Sub FixTable()
Application.ScreenUpdating = False
Dim r As Long, c As Long, RngSrc As Range, RngTgt As Range
With ActiveDocument.Tables(1)
  For r = .Rows.Count To 3 Step -1
    IsDate (Trim(Split(.Cell(r, 1).Range.Text, vbCr)(0)))
    If IsDate(Trim(Split(.Cell(r, 1).Range.Text, vbCr)(0))) = False Then
      For c = 1 To .Rows(r).Cells.Count
        Set RngSrc = .Cell(r, c).Range
        If RngSrc.Paragraphs.Count > 1 Then
        RngSrc.End = RngSrc.Paragraphs(1).Range.End - 1
        Set RngTgt = .Cell(r - 1, c).Range
        With RngTgt
          .End = .End - 1
          .Collapse wdCollapseEnd
          .FormattedText = RngSrc.FormattedText
          .InsertBefore " "
        End With
        RngSrc.Paragraphs(1).Range.Text = vbNullString
        End If
      Next
    End If
  Next
End With
Application.ScreenUpdating = True
End Sub