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