I write up to about 1000 bytes of text to a cell. Wrap is set.
Sometimes, the cell is taller than it should be by a line of text.
Up to now, most lines have been 17 pixels high and I had a simple macro
to adjust such a cell. I have recently enhanced that macro to deal with
an arbitrary line height. I do not like my code - particularly my
inability to copy a font object with a simple mechanism.
In the code below,
set ActiveCell.Characters(Start:=1, Length:=1).Font = f
gets Run-time error '438' Object doesn't support this property or method
I find I have to copy elements explicitly.
I don't understand why.
debug.print ActiveCell.Characters(Start:=1, Length:=1).Font.Name
works at that point.

I would appreciate helpful advice. Thanks.

Option Explicit

Private Function LineHeight() As Double
' Get pixel height of text in the 2nd cell in the Excel active row.
Dim cell As Range
Dim f As Font
Dim I As Long

' Hide creation and deletion of a temporary row.
Application.ScreenUpdating = False
Set cell = Cells(ActiveCell.Row, 2)
Set f = cell.Characters(Start:=1, Length:=1).Font
For I = 2 To Len(cell.Text)
If f.Size < cell.Characters(Start:=I, Length:=1).Font.Size Then
Set f = cell.Characters(Start:=I, Length:=1).Font
End If
Next I
cell.EntireRow.Insert
ActiveCell = "X"
' set ActiveCell.Characters(Start:=1, Length:=1).Font = f
' gets Run-time error '438'
' Object doesn't support this property or method

With ActiveCell.Characters(Start:=1, Length:=1).Font
.Name = f.Name
.FontStyle = f.FontStyle
.Size = f.Size
.Strikethrough = f.Strikethrough
.Superscript = f.Superscript
.Subscript = f.Subscript
.OutlineFont = f.OutlineFont
.Shadow = f.Shadow
.Underline = f.Underline
.ColorIndex = f.ColorIndex
End With
LineHeight = ActiveCell.RowHeight
ActiveCell.EntireRow.Delete Shift:=xlUp
Application.ScreenUpdating = True
End Function

Sub squeezeRow()
'
' squeezeRow Macro
' Macro recorded 10/06/2012 by IBM
'
' Keyboard Shortcut: Ctrl+s
'
' Decrement the number of lines occupied by the active row.
'
' Logic assumes each line is 12.75 points (equivalent to 17 pixels)
' 07/10/2013 - remove that assumption
'
Dim InitialHeight As Double ' height of active row in points
' Const Oneline As Double = 12.75 ' points in single text line row
Dim Oneline As Double
Dim lines As Long
Dim Pixels As Long

Oneline = LineHeight
InitialHeight = ActiveCell.RowHeight
Pixels = InitialHeight * 4
Debug.Assert Pixels Mod 3 = 0
Pixels = Pixels / 3
lines = InitialHeight / Oneline
Debug.Assert InitialHeight = lines * Oneline
If InitialHeight < Oneline * 2 Then Exit Sub
ActiveCell.RowHeight = (lines - 1) * Oneline
End Sub
--
Walter Briscoe