Sub CellXfer()
Application.ScreenUpdating = False
Dim i As Long, RngTbl As Range, RngCell As Range
Set RngTbl = Selection.Range
On Error Resume Next
With RngTbl
  If .Information(wdWithInTable) = True Then
    For i = 1 To .Cells.Count Step 2
      If .Cells(i).Row.Index = .Cells(i + 1).Row.Index Then
        Set RngCell = .Cells(i + 1).Range
        With RngCell
          .End = .End - 1
          .Cut
        End With
        Set RngCell = .Cells(i).Range
        With RngCell
          .End = .End - 1
          If Len(.Text) = 0 Then
            .Paste
          ElseIf .Characters.Last = vbCr Then
            .Collapse wdCollapseEnd
            .Paste
          Else
            .Characters.Last.InsertAfter vbCr
            .Collapse wdCollapseEnd
            .Paste
          End If
        End With
      End If
    Next
  End If
End With
Application.ScreenUpdating = True
End Sub