Use the following:

Dim flag As Boolean, arange As Range, i, j, k

Set arange = Selection.Cells(1).Range
k = arange.Font.Size
flag = False
Do While flag = False
   arange.End = arange.End - 1
   arange.Select
   i = arange.Information(wdVerticalPositionRelativeToPage)
   arange.Collapse wdCollapseEnd
   j = arange.Information(wdVerticalPositionRelativeToPage)
   If j > i Then
       Set arange = Selection.Cells(1).Range
       arange.Font.Size = k - 0.5
       k = arange.Font.Size
   Else
       flag = True
   End If
Loop