Font adjusts to size of cell

[John Michl]

I wondering if anyone has any ideas on automatically changing the size
of a font to adjust to the size of a cell. I'm thinking something
like...

If Length of cell contents < x then adjust font to fit on one line
If Length of cell contents >x but then adjust font to maximize on two
lines

All, of course, without increase the row height.

Thanks

- John

 

[Crowbar via OfficeKB.com]

Don't really know what you mean but you could

click format cells > alignment > tick the shrink to fit option

 

[John Michl]

It seems that shrink to fit and wrap text are mutually exclusive. I
need to be able to allow shrinking to fit but in a cell that allows to
lines of text.

- John

 

[Peter T]

Hi John,

This is only lightly tested but have a go

Function AutoSizeFont(rng As Range)
Dim ndRh As Double, ndFntSze As Double
Dim cel As Range
Dim rDoItIn As Range

' Fit text in cell to existing cell width & height

On Error GoTo errH
Application.ScreenUpdating = False
With rng.Parent.UsedRange
'error if UR extends to end row or column
Set rDoItIn = rng.Parent.Cells(.Rows.Count + _
.Rows(1).Row, .Columns.Count + .Columns(1).Column)
End With

rng.WrapText = True
rng.VerticalAlignment = xlCenter

For Each cel In rng
ndRh = cel.Height
With rDoItIn

.RowHeight = ndRh
.ColumnWidth = cel.ColumnWidth
.Value = cel.Value
.WrapText = True

With .Font
.Size = 4

Do
ndFntSze = .Size
.Size = ndFntSze + 0.25
rDoItIn.Rows(1).AutoFit
Loop Until rDoItIn.Height >= ndRh

If rDoItIn.Height > ndRh Then
cel.Font.Size = ndFntSze
Else
cel.Font.Size = .Size
End If

End With
End With
Next
rng.Parent.Rows(rDoItIn.Rows(1).Row).EntireRow.Delete

errH:
Application.ScreenUpdating = True

If Err.Number Then
MsgBox "Error"
End If

End Function

Regards,
Peter T

 

[John Michl]

Thanks Peter. I'll give it a spin.

- John

 

[Peter T]

Function as posted should be considered as beta v1.0 !

I should have explained how it works
Get a temporary cell (rDoItIn) one below & right of the usedrange in which
to adjust font.
Put in the text and fix dimensions to same as the looped input cells.
Gradually increase font size and autofit the row until height is same as
input cell.
WrapText to enable multiple rows.
Resize input cell's font.

Needs more refining, eg

- restrict input cells to those in the used range
- ensure font name is consistent
- even with text wrap, the longest word might extend to the right of the
column when resizing to fit row height (also need to autofit column-width)

I'll leave it for a while in case you (John) or anyone else chime in with
anything else that needs fixing.

Peter T