[Klaus Linke]

I knew I shoould have tested that macro!

1st, font sizes must be multiples of 0.5 pt, so with
multiplication/division, it can run into endless loops.

2nd, because the font size needs to be a multiple of 0.5 pt, the text can't
be fitted perfectly. For the rest, you can use the paragraph alignment
"distributed", which should be hardly noticeable once the font size is as
close as possible to the optimum:

Sub FitPara()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngPara As Range
Set rngPara = Selection.Paragraphs(1).Range
Set rngStart = Selection.Paragraphs(1).Range.Characters.First
Set rngEnd = Selection.Paragraphs(1).Range.Characters.Last
rngEnd.MoveWhile Cset:=Chr(13) & Chr(11) & Chr(7), Count:=wdBackward
rngEnd.Collapse (wdCollapseStart)
rngPara.ParagraphFormat.Alignment = wdAlignParagraphLeft
If Selection.Paragraphs(1).Range.Font.Size = wdUndefined Then
MsgBox "Paragraph does not have uniform font size", _
vbExclamation, "Macro cancelled:"
Exit Sub
End If
If rngEnd.start = rngStart.start + 1 Then
MsgBox "No paragraph to fit was found", _
vbExclamation, "Macro cancelled:"
Exit Sub
End If
While rngStart.Information(wdVerticalPositionRelativeToT extBoundary) = _
rngEnd.Information(wdVerticalPositionRelativeToTex tBoundary)
rngPara.Font.Size = rngPara.Font.Size * 2
Wend
While rngStart.Information(wdVerticalPositionRelativeToT extBoundary) _
rngEnd.Information(wdVerticalPositionRelativeToTex tBoundary)
rngPara.Font.Size = rngPara.Font.Size - 0.5
Wend
rngPara.ParagraphFormat.Alignment = wdAlignParagraphDistribute
End Sub