Sub ShrinkCellTextToFit()
Dim orng As Range
Dim i As Long
Const iCol As Integer = 2        'the column to process

    If Not Selection.Information(wdWithInTable) Then
        MsgBox "Put the cursor in the table and try again"
        GoTo lbl_Exit
    End If
    For i = 1 To Selection.Tables(1).Rows.Count
        Set orng = Selection.Tables(1).Cell(i, iCol).Range
        orng.End = orng.End - 1
        Do Until orng.ComputeStatistics(wdStatisticLines) = 1
            orng.Font.Shrink
        Loop
    Next i
lbl_Exit:
    Exit Sub
End Sub