Sub Demo()
Application.ScreenUpdating = False
Dim xlObj As Object, xlWkBkObj As Object
With Selection.Tables(1).Range
  'Pre-format the table
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[^13^l]"
    .Replacement.Text = Chr(182)
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  'Copy the table
  .Copy
End With
ActiveDocument.Undo
'Start Excel if not running
On Error Resume Next
Set xlObj = GetObject(, "Excel.Application")
' Start Excel if it isn't running
If xlObj Is Nothing Then Set xlObj = CreateObject("Excel.Application")
With xlObj
  'Add a workbook
  Set xlWkBkObj = .Workbooks.Add
  With xlWkBkObj.Sheets(1)
  'Paste the data
    .Paste '.Range("A1")
    'Post-format the data
    With .UsedRange
      .HorizontalAlignment = 1 'xlGeneral
      .WrapText = False
      .Columns.AutoFit
      .Replace Chr(182), Chr(10)
      .Columns.AutoFit
      .Rows.AutoFit
    End With
  End With
  .CutCopyMode = False
  .Visible = True
End With
Application.ScreenUpdating = True
End Sub