Compare textwidth with cellwidth in Excel?

[D Larsson]

Hello

I have a worksheet in Excel. Now I need to know if I have to adjust
cellwidths (or height) to get all text to fit in the cells.
I can't use AutoFit as it doesn't work with merged cells (ms article:
Q212010).
I tried to do this with API, but it doesn't give me an accurate respons.

Here's my testcode:

Sub TestFont()
Dim font As LOGFONT
Dim prevFont As Long, hFont As Long, ret As Long
Dim hWnd As Long, hdc As Long

Dim vStr_Txt As String, vLng_X As Long
Dim lpSize As Size, RetVal As Long

'Device context to active object
hWnd = GetFocus()
hdc = GetDC(hWnd)

'Font-data (fontsize in pixels)
font.lfFaceName = Range("C8").font.Name & Chr$(0)
font.lfHeight = -MulDiv((Range("C8").font.Size), GetDeviceCaps(hdc,
LOGPIXELSY), 72)

'Creates temporary Font
hFont = CreateFontIndirect(font)
If hFont = 0 Then Exit Sub
prevFont = SelectObject(hdc, hFont)

'Width of text in specified cell
vStr_Txt = Range("C8") & ""
RetVal = GetTextExtentPoint32(hdc, vStr_Txt, Len(vStr_Txt), lpSize)
MsgBox "Textwidth:" & lpSize.cx

'Width of specified cell
vLng_X = ActiveWorkbook.ActiveSheet.Range("C8").Width
MsgBox "Cellwidth: " & MulDiv((vLng_X), GetDeviceCaps(hdc, LOGPIXELSX),
72)

'Restores.
ret = SelectObject(hdc, prevFont)
ret = DeleteObject(hFont)
End Sub

When I've tried this I've set the text to "Test" and then used the
autofit-function to adjust width of cell.
The textwidth shows 38 pixels, but the cellwidth shows 47.
If I set the cellwidth to 38, the text fits exactly. But if I do the same
thing with a number, the cell only shows the character #.

Is there any way to know how much extra space excel needs to show numbers?
Is it a fixed width in Excel that I can use?

Help would be much appreciated
Daniel

[Jim Rech]

Yhis macro does an autofit of row heights on merged cells:

''Simulates row height autofit for a merged cell if the active cell..
'' is merged.
'' has Wrap Text set.
'' includes only 1 row.
''Unlike real autosizing the macro only increases row height
'' (if needed). It does not reduce row height because another
'' merged cell on the same row may needed a greater height
'' than the active cell.
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth +
MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub

--
Jim Rech
Excel MVP

[D Larsson]

Thank's Jim, this will do. I enhanced it a bit, to be more accurate when
many cells have been merged. Look below.

/Daniel

Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single

Dim CurrCell As Range, RangeWidth As Single

Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth

RangeWidth = .Width

For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth +
MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth

While .Cells(1).Width < RangeWidth
.Cells(1).ColumnWidth = .Cells(1).ColumnWidth + 0.5
Wend
.Cells(1).ColumnWidth = .Cells(1).ColumnWidth - 0.5

[martins....@gmail.com]

Hello Jim,

Excellent macro.
I'm wondering if there's a way of doing this in multiple rows at once. Is this possible?

JC

[haris.a...@gmail.com]

I found this code and made improvement so it can support multiple cells selection. It's little bit tricky to deal with vertical oriented text but this code support it as well (small correction is required to switch off text wrapping in case of vertical text orientation, but I omit to do it - no more time). Code checks user selection and does not support entire rows our columns selection although it can work with it (just remove checking code). Thanks guys for starting code and my code version is the following:

Sub AutoFitMergedCellRowHeight()
Dim cell As Object

Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range

Dim PrevMerge As Range

Dim ActiveCellWidth As Single, PossNewRowHeight As Single

Dim FirstCell As Boolean
If Selection.Address = "$1:$1048576" Then
MsgBox ("This macro procedure for RowAutofit does not support entire rows or columns selection")
Exit Sub
End If
If Selection.Row > 0 And Selection.count >= Columns.count Then
MsgBox ("This macro procedure for RowAutofit does not support entire rows or columns selection")
Exit Sub
End If
If Selection.Column > 0 And Selection.count >= Rows.count Then
MsgBox ("This macro procedure for RowAutofit does not support entire rows or columns selection")
Exit Sub
End If
FirstCell = True
Set PrevMerge = Selection.Cells(1).MergeArea
For Each cell In Selection
If cell.MergeArea.Address <> PrevMerge.Address Or FirstCell Then
With cell.MergeArea
If .Rows.count = 1 And .WrapText = True Then

Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight

ActiveCellWidth = cell.ColumnWidth
For Each CurrCell In cell.MergeArea
CurrCell.Orientation = cell.MergeArea.Cells(1).Orientation

MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)

CurrentRowHeight = 0
ActiveCellWidth = 0
MergedCellRgWidth = 0
PossNewRowHeight = 0

End If
End With
End If

Set PrevMerge = cell.MergeArea
Application.ScreenUpdating = True
FirstCell = False
Next cell
End Sub