Sub MailMergeToDoc()
Application.ScreenUpdating = False
Dim Tbl As Table, Rng As Range, c As Long
ActiveDocument.MailMerge.Execute
For Each Tbl In ActiveDocument.Tables
  With Tbl
    For c = .Columns.Count - 1 To 1 Step -1
    .Columns.Add
    Set Rng = .Columns(c).Cells(1).Range
    Rng.End = Rng.End - 1
    .Columns.Last.Cells(1).Range.FormattedText = Rng.FormattedText
    .Columns(c).Delete
    Next
  End With
Next
Application.ScreenUpdating = True
End Sub