Sub a_macro()
    
    Dim d As Document. t As Table, r As Long, c As Long, rw As Row
    Set d = ActiveDocument
    Set t = d.Tables(1)
    
    For r = 3 To t.Rows.Count
         Set rw = t.Rows(r)
        
        For c = 1 To rw.Cells.Count
            If c = 1 Then
                t.Cell(r, c).Range.Copy

            ElseIf c = 2 Then
                 t.Cell(r, c).Range.PasteAndFormat (wdFormatOriginalFormatting)
            End If
        Next c
    Next r
    
End Sub

Sub Demo()
Application.ScreenUpdating = False
Dim r As Long, Rng As Range
With ActiveDocument.Tables(1)
  For r = 3 To .Rows.Count
    With .Rows(r)
      If .Cells.Count > 1 Then
        Set Rng = .Cells(1).Range
        Rng.End = Rng.End - 1
        .Cells(2).Range.FormattedText = Rng.FormattedText
      End If
    End With
  Next r
End With
Application.ScreenUpdating = True
End Sub