Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.
Dismiss

Compare textwidth with cellwidth in Excel?

6,716 views
Skip to first unread message

D Larsson

unread,
Mar 26, 2002, 5:53:24 AM3/26/02
to
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

unread,
Mar 26, 2002, 6:54:59 AM3/26/02
to
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

unread,
Mar 26, 2002, 9:06:20 AM3/26/02
to
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

unread,
Sep 27, 2012, 10:46:21 AM9/27/12
to
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

unread,
Sep 11, 2015, 11:25:19 AM9/11/15
to
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
0 new messages