Microsoft Office Forums - View Single Post - [Solved] table and code accidentally working only on odd rows

gmayor · 08-12-2016, 10:54 PM

The reason that the merge produces a separate table for each record is that the merge document contains a section break, which forces the creation of a new table. Remove the section break from the merge document and the merge is to separate rows.

Adding the paragraph collection, as I suggested processes all the first column paragraphs, whether there is one table or many.

Code:

Option Explicit
Sub ShrinkParagraphText()
Dim oTable As Table
Dim oRow As Row
Dim oCell As Cell
Dim oRng As Range
Dim oPara As Paragraph
    For Each oTable In ActiveDocument.Tables
        For Each oRow In oTable.Rows
            Set oCell = oRow.Cells(1)
            For Each oPara In oCell.Range.Paragraphs
                Set oRng = oPara.Range
                oRng.End = oRng.End - 1
                Do While NumLines(oRng) > 1
                    oRng.Font.Shrink
                Loop
            Next oPara
        Next oRow
    Next oTable
lbl_Exit:
    Set oTable = Nothing
    Set oRow = Nothing
    Set oCell = Nothing
    Set oRng = Nothing
    Set oPara = Nothing
    Exit Sub
End Sub

Function NumLines(rng As Range) As Long
Const wdStatisticLines As Long = 1
    NumLines = rng.ComputeStatistics(wdStatisticLines)
lbl_Exit:
    Exit Function
End Function