Sub ReLabelTables()
Application.ScreenUpdating = False
Dim i As Long, oPrev As Range, oNext As Range
With ActiveDocument
  For i = .Tables.Count To 1 Step -1
    With .Tables(i).Range
      Set oPrev = .Characters.First.Previous.Characters.Last
      Set oNext = .Characters.Last.Next.Paragraphs.First.Range
      With oPrev
        .InsertBefore vbCr
        .Start = .End - 1
        .Style = oNext.Style
        .End = .Start
        If Len(oNext.Text) > 1 Then
          With oNext
            .End = .End - 1
            .Cut
            .Delete
          End With
          .Paste
        Else
          oNext.Delete
        End If
      End With
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub