Sub RepairTbl()
Dim i As Long, j As Long, Tbl As Table
Dim pWdth As Single, sCWdth As Single, bkClr As Long
With ActiveDocument
  Set Tbl = .Tables(1)
  With Tbl
    .AllowAutoFit = False
    .Cell(1, 1).PreferredWidthType = wdPreferredWidthPoints
    pWdth = .Cell(1, 1).PreferredWidth
    With .Range
      On Error Resume Next
      For i = .Cells.Count To 1 Step -1
        If .Cells(i).ColumnIndex = 1 Then
          Tbl.Split Tbl.Range.Cells(i).RowIndex
        End If
      Next
      On Error GoTo 0
    End With
  End With
  For Each Tbl In .Tables
    With Tbl
      .AllowAutoFit = False
      With .Rows
        .Alignment = wdAlignRowLeft
        .LeftIndent = 0
        .WrapAroundText = False
      End With
    End With
  Next
  For i = 1 To .Tables.Count
    sCWdth = 0
    With .Tables(i)
      .AllowAutoFit = False
      .PreferredWidthType = wdPreferredWidthPoints
      .PreferredWidth = pWdth
      With .Range
        If .Cells.Count = 1 Then
          bkClr = .Cells(1).Shading.BackgroundPatternColorIndex
        End If
      End With
      .Style = "Table Normal"
      With .Range
        For j = 1 To .Cells.Count
          sCWdth = sCWdth + .Cells(j).Width
        Next
        If sCWdth <> pWdth Then
          For j = 1 To .Cells.Count
            .Cells(j).Width = .Cells(j).Width * pWdth / sCWdth
          Next
        End If
        If .Cells.Count = 1 Then
          If bkClr <> 0 Then .Cells(1).Shading.BackgroundPatternColorIndex = bkClr
        End If
      End With
    End With
  Next
  While .Tables.Count > 1
    .Tables(1).Range.Characters.Last.Next.Select
    Selection.Delete
  Wend
  With .Tables(1)
    .Borders.Enable = True
    .Rows.Alignment = wdAlignRowCenter
  End With
End With
End Sub