Fix irregular shape of merged tables in MS Word 2007

[iyoossaev]

I have been looking for the answer to this for quite some time, but to no avail, so I hope someone here will be able to help me.



I have recently exported a document from FineReader 12 to word. The document is basically a 130-page-long table. The table has a regular shape: 5 columns, no merged cells.

However, when I merge individual tables (FineReader splits them by page) into one by deleting the lines between them, the table gets an irregular shape on each joint, like this.

Given the sheer number of tables I have, is there a way to reset their shape altogether? So far it seems I have to manually adjust each table's columns to fit the other ones.

I have tried resetting the table and column width, text wrapping etc.; I also selected the entire table and checked, then unchecked the "table header" tick for all.

Converting table to text and back doesn't work, because some cells have paragraph breaks, and that's to be dealt with later.

[macropod]

The problem is that your tables have differing layouts. The simplest solution would be to use a macro to format all of the tables with the same layout, then delete the intervening paragraph breaks. For example:

Sub FixTables()
Application.ScreenUpdating = False
Dim Tbl As Table
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
      .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)
  End With
  While .Tables.Count > 1
    .Tables(1).Range.Characters.Last.Next.Delete
  Wend
Next
End With
Application.ScreenUpdating = True
End Sub

For PC macro installation & usage instructions, see: http://www.gmayor.com/installing_macro.htm

[iyoossaev]

Thank you very much for responding.

I have just tried your macro and it gave me runtime error 5992, saying that I cannot access specific columns in the collection, because cells have different width. It did combine the tables, but the problem of varying column width persisted.

Would you be so kind as to suggest what might be wrong? Perhaps the macro should include formatting cell width to default?

[macropod]

The error suggests your document has one or more tables where the cell widths in a given column differ. That's only something I expected to occur if you had already merged some tables. That said, the following modifications should address the issue:

Sub FixTables()
Application.ScreenUpdating = 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
      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
          Select Case (i - 1 Mod 5) + 1
            Case 1: .Range.Cells(i).Width = CentimetersToPoints(1#)
            Case Else: .Range.Cells(i).Width = CentimetersToPoints(3.75)
          End Select
        Next
      End If
  End With
  While .Tables.Count > 1
    .Tables(1).Range.Characters.Last.Next.Delete
  Wend
Next
End With
Application.ScreenUpdating = True
End Sub

There is no such thing as a default cell width in Word.

[iyoossaev]

Originally Posted by macropod

The error suggests your document has one or more tables where the cell widths in a given column differ. That's only something I expected to occur if you had already merged some tables.

Weird, I paid attention not to merge any in a freshly-generated file.

Originally Posted by macropod

There is no such thing as a default cell width in Word.

Indeed, my wording could have been better — I meant that by default cell width is inherited after column width.

Originally Posted by macropod

That said, the following modifications should address the issue

And they did — you literally saved me dozens of hours of work. Thanks a bunch!

The only downside is that while it takes seconds to parse 2 pages worth of tables, it takes forever to parse 20 pages with numerous prompts in-between. But I guess that's hardware and Word itself.

[iyoossaev]

Is there any way to suppress the prompts in the macro that ask if I should continue with irreversible changes?

Edit: I think I actually found the solution to that, leaving it for posteriority with similar problems.
It suffices to add

Application.Displayalerts = False

at the beginning, and

Application.Displayalerts = True

at the end to restore the prompts back.

[macropod]

OK, try this version:

Sub FixTables()
Application.ScreenUpdating = 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
      .Columns.DistributeWidth
      .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)
  End With
  While .Tables.Count > 1
    .Tables(1).Range.Characters.Last.Next.Delete
  Wend
Next
End With
Application.ScreenUpdating = True
End Sub

What are the prompts? Without knowing what they are, I can't say whether there's a better approach than toggling Displayalerts.

[iyoossaev]

Thanks for getting back to me again.

The prompts it gives me are (roughly translating):
Program Word has encountered an error. After completing this operating it will be irreverisible. Do you want to continue?
When I click yes, it goes on for a bit before asking again; whenI press no, it gives me a series of identical prompts, but force-quitting this chain leaves the fille partially of fully "fixed" with respect to tables.

I tried your last solution, but I am getting runtime error 4605, saying that when cells spanning multiple rows are selected, the number of columns must be the same. I don't get that when I use the previous solution on the same file, but it is possible something is merged somewhere

[macropod]

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:

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

[iyoossaev]

Thanks for yet another contribution. It is difficult to say by eye if the overall perfomance is better not., but I trust it is. It's by far the best solution I've come across and it does work even if I miss merged cells, so I will proceed to use this. Cheers!