Microsoft Office Forums - View Single Post - [Solved] Fix irregular shape of merged tables in MS Word 2007

macropod · 01-05-2016, 04:05 PM

The prompts are merely telling you there'll be too many edits for Word to undo. In this case, toggling DisplayAlerts is probably the best way of handling it.

If there are cells spanning multiple rows, your table has merged cells, contrary to what you previously advised. In that case, you'll need to iterate through the cells of the tables concerned. That said, you may get a slight performance increase with:

Code:

Sub FixTables()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Tbl As Table, i As Long
With ActiveDocument
  For Each Tbl In .Tables
    With Tbl
      With .Rows
        .LeftIndent = 0
        .WrapAroundText = False
        .Alignment = wdAlignRowCenter
      End With
      .TopPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .BottomPadding = 0
      .AllowAutoFit = False
      .PreferredWidthType = wdPreferredWidthAuto
      On Error Resume Next
      .Columns.DistributeWidth
      On Error GoTo 0
      If .Uniform Then
        .Columns(1).Width = CentimetersToPoints(1#)
        .Columns(2).Width = CentimetersToPoints(3.75)
        .Columns(3).Width = CentimetersToPoints(3.75)
        .Columns(4).Width = CentimetersToPoints(3.75)
        .Columns(5).Width = CentimetersToPoints(3.75)
      Else
        For i = 1 To .Range.Cells.Count
          With .Range.Cells(i)
            If .ColumnIndex = 1 Then
              .Width = CentimetersToPoints(1#)
            Else
              .Width = CentimetersToPoints(3.75)
            End If
          End With
        Next
      End If
  End With
  While .Tables.Count > 1
    .Tables(1).Range.Characters.Last.Next.Delete
  Wend
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub