How To Determine Length Of Variable-Font Text?

[PeteCresswell]

This is a spinoff from the "'ColumnOverflow'" Function?" thread
because it seems like a sufficiently-different question to warrent
it's own subject line....


I've got a little routine that boogies through rows/columns, looking
for cells rendered as "#" and expands columns to get rid of the "#".
This applies to date and numeric cells.

But now I would like to do the same thing with text cells.

I've got it working - sort of... - for monospaced fonts, but I would
like to make it handle variable-spaced fonts.

There are a lot of Google hits around this, but none of them really
cut to the chase for my situation.

Can anybody point me to something?

Here's my current code:
---------------------------------------------------------
Sub ExpandColumns()
Dim curCell As Range

Dim lastRow As Long
Dim lastCol As Long
Dim lastCell As Long

Dim i As Long
Dim R As Long
Dim C As Long

Dim curWid As Double

Const incWid As Double = 0.1
Const maxWid As Long = 50

Application.ScreenUpdating = False

If WorksheetFunction.CountA(Cells) > 0 Then
lastCol = Cells.Find(What:="*", After:=[A1],
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
lastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

For R = 1 To lastRow
For C = 1 To lastCol
curWid = Columns(C).Width
Set curCell = Cells(R, C)

If Left(curCell.Text, 1) = "#" Then
Do Until Left(curCell.Text, 1) <> "#"
curWid = curWid + incWid
Columns(C).ColumnWidth = curWid / 10
Loop
End If
Next C
Next R

Application.ScreenUpdating = True
Set curCell = Nothing
End If
End Sub
---------------------------------------------------------

 

[PeteCresswell]

Code Correction.

I pasted the wrong version of code into the sample.

Here is the latest-and-greatest:
--------------------------------------------------------
Sub ExpandCols()
Dim curCell As Range

Dim lastRow As Long
Dim lastCol As Long
Dim lastCell As Long

Dim R As Long
Dim C As Long

Dim curWid As Double

Const incWid As Double = 1
Const maxWid As Long = 50
Const slopFactor As Long = 2

Application.ScreenUpdating = False

If WorksheetFunction.CountA(Cells) > 0 Then
' ---------------------------------------------
' Determine last column/row

lastCol = Cells.Find(What:="*", After:=[A1],
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
lastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

' ---------------------------------------------
' Make each column big enough to render largest text plus a slop
factor

For R = 1 To lastRow
For C = 1 To lastCol
curWid = Columns(C).ColumnWidth
Set curCell = Cells(R, C)

If Left(curCell.Text, 1) = "#" Then
Do Until Left(curCell.Text, 1) <> "#"
curWid = curWid + incWid
Columns(C).ColumnWidth = curWid
Loop
Columns(C).ColumnWidth = Columns(C).ColumnWidth + 2
End If
Next C

Next R

Application.ScreenUpdating = True

' ---------------------------------------------
' - Make header row alignments same as detail row alignments
' except for dates where we force alignment to center

For C = 1 To lastCol
If IsDate(Cells(2, C)) Then
Columns(C).HorizontalAlignment = xlCenter
Else
Cells(1, C).HorizontalAlignment = Cells(2,
C).HorizontalAlignment
End If

Cells(1, C).Interior.ColorIndex = 15
Next C

Set curCell = Nothing
End If
End Sub
--------------------------------------------------------

 

[Dave Peterson]

If you're getting #######'s to appear for text cells, then widening the column
is not the solution.

You can change the format to General (or anything but Text).

Excel has a display problem with strings between 256 and 1024 characters long in
cells formatted as text.

This is a spinoff from the "'ColumnOverflow'" Function?" thread
because it seems like a sufficiently-different question to warrent
it's own subject line....

I've got a little routine that boogies through rows/columns, looking
for cells rendered as "#" and expands columns to get rid of the "#".
This applies to date and numeric cells.

But now I would like to do the same thing with text cells.

I've got it working - sort of... - for monospaced fonts, but I would
like to make it handle variable-spaced fonts.

There are a lot of Google hits around this, but none of them really
cut to the chase for my situation.

Can anybody point me to something?

Here's my current code:
---------------------------------------------------------
Sub ExpandColumns()
Dim curCell As Range

Dim lastRow As Long
Dim lastCol As Long
Dim lastCell As Long

Dim i As Long
Dim R As Long
Dim C As Long

Dim curWid As Double

Const incWid As Double = 0.1
Const maxWid As Long = 50

Application.ScreenUpdating = False

If WorksheetFunction.CountA(Cells) > 0 Then
lastCol = Cells.Find(What:="*", After:=[A1],
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
lastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

For R = 1 To lastRow
For C = 1 To lastCol
curWid = Columns(C).Width
Set curCell = Cells(R, C)

If Left(curCell.Text, 1) = "#" Then
Do Until Left(curCell.Text, 1) <> "#"
curWid = curWid + incWid
Columns(C).ColumnWidth = curWid / 10
Loop
End If
Next C
Next R

Application.ScreenUpdating = True
Set curCell = Nothing
End If
End Sub
---------------------------------------------------------

 

[PeteCresswell]

If you're getting #######'s to appear for text cells, then widening the column
is not the solution.

Agreed.

My approach for text cells will differ.

Instead of looking for "#", I think I should be determining the length
of the text as it will be rendered using the
Cell.Font.Name, .Size, .Bold... and whatever else... and then
comparing that length to Column.ColumnWidth and adjusting the column's
width accordingly.

Problem is I don't have a clue as to how to determine with width of a
text string given a specified font + the font's characteristics (like
size, bold, italic and so-forth).

 

[PeteCresswell]

Problem is I don't have a clue as to how to determine with width of a
text string given a specified font + the font's characteristics (like
size, bold, italic and so-forth).

If push came to shove, I suppose I *could* paste the string in
question into an invisible cell somewhere - with autofit or whatever
turned on, set the cell's .Font props, and then retrieve .ColumnWidth.

But I suspect that would kick the brains out of response time.

 

[Rick Rothstein]

Problem is I don't have a clue as to how to determine with

If push came to shove, I suppose I *could* paste the string
in question into an invisible cell somewhere - with autofit or
whatever turned on, set the cell's .Font props, and then
retrieve .ColumnWidth.

But I suspect that would kick the brains out of response time.

Response time? No, not really...

Dim Source As Range, InvisibleCell As Range
Set Source = Range("C6")
Set InvisibleCell = Range("C6").Offset(26, 3)
Source.Copy InvisibleCell
InvisibleCell.Columns.AutoFit
If InvisibleCell.ColumnWidth > Source.ColumnWidth Then
MsgBox "The text is too long!"
Else
MsgBox "The text fits!!!"
End If

Note that the column for the "invisible cell" cannot be the same column as
for the "source cell". In the above code, just set the Source and
InvisibleCell values as needed or desired. I will point out, though, that
this (or probably the API equivalents) will seem to return "text is too
long" messages for text that **looks** like it fits... the reason is because
there is an invisible box around each character with a blank area (in a
"normal" looking font) all around the character (for spacing purposes when
butted up against an adjacent character) which, if any part of it breaches
the cell's edge (even if what we see as the character appears wholly inside
the cell), will report the text as being wider than the cell.

 

[PeteCresswell]

I will point out, though, that
this (or probably the API equivalents) will seem to return "text is too
long" messages for text that **looks** like it fits... the reason is because
there is an invisible box around each character with a blank area (in a
"normal" looking font) all around the character (for spacing purposes when
butted up against an adjacent character) which, if any part of it breaches
the cell's edge (even if what we see as the character appears wholly inside
the cell), will report the text as being wider than the cell.

For my application that's a "plus", since I am already adding a "slop
factor" to my sizes so the data does not look to scrunched up within
the cell.

I'll give this a shot later today.

Thanks!

 

[Rick Rothstein]

I will point out, though, that

For my application that's a "plus", since I am already adding
a "slop factor" to my sizes so the data does not look to
scrunched up within the cell.

I'll give this a shot later today.

In your original thread, you were resizing the column to fit the cell entry.
If you are still doing that, but for text this time, then you want to change
the column width to fit the longest text in the column (no matter what cell
that is in) unless the text all fits, in which case you want to leave the
existing column width alone. If you are still trying to do that, consider
this approach for the text handling part of your code...

Dim CW As Double, Source As Range
Set Source = Range("E5")
CW = Source.ColumnWidth
Source.Columns.AutoFit
If Source.ColumnWidth < CW Then Source.ColumnWidth = CW

 

[PeteCresswell]

Dim CW As Double, Source As Range
Set Source = Range("E5")
CW = Source.ColumnWidth
Source.Columns.AutoFit
If Source.ColumnWidth < CW Then Source.ColumnWidth = CW

Now that it's finally dawned on me... I'm using that approach for all
columns.

Takes about 5 seconds for 375 rows x 10 columns.

The agenda is to have a "ScratchPad.xls" handy for when I need to run
a database query, paste the results into Excel, and email the .XLS to
somebody.

The code in question beautifies the sheet - bolding the header row,
expanding columns to fit, and right/left/center justifying columns
depending on data type.

Seems to work well enough, although it could be faster.

Here's the whole enchilada. I have an accellerator key "M"
programmed to execute "Beautify", so I just select the upper-left cell
of the sheet, paste the entire contents of whatever query I'm
running , do a Ctl+M, and I'm good to go. Thanks for the help.
-----------------------------------------------------------------------------------------------
Sub Beautify()
SetFont
ExpandCols
FixHeader
Cells(1, 1).Select
End Sub

Sub ExpandCols()
Dim curCell As Range
Dim testCell As Range

Dim lastRow As Long
Dim lastCol As Long
Dim lastCell As Long

Dim R As Long
Dim C As Long

Dim curWid As Double

Const incWid As Double = 1
Const maxWid As Long = 50
Const slopFactor As Long = 2


If WorksheetFunction.CountA(Cells) > 0 Then
' ---------------------------------------------
' Turn screen updating off to speed things up

Application.ScreenUpdating = False

' ---------------------------------------------
' - Determine last column/row
' - Set a pointer to a cell just beyond our last populated cell

lastCol = Cells.Find(What:="*", After:=[A1],
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
lastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

Set testCell = Cells(lastRow + 1, lastCol + 1)

' ---------------------------------------------
' Make each column big enough to render largest text,
' but exclude headers from this operation

For R = 2 To lastRow
For C = 1 To lastCol
Set curCell = Cells(R, C)
curWid = curCell.ColumnWidth

curCell.Copy testCell

With testCell
.WrapText = False
.Columns.AutoFit
If .ColumnWidth > curWid Then
Columns(C).ColumnWidth = .ColumnWidth
End If
End With
Next C

Next R

testCell.Value = Null

' ---------------------------------------------
' - Make header row alignments same as detail row alignments
' except for dates where we force alignment to center

For C = 1 To lastCol
If IsDate(Cells(2, C)) Then
Columns(C).HorizontalAlignment = xlCenter
Else
Cells(1, C).HorizontalAlignment = Cells(2,
C).HorizontalAlignment
End If

Cells(1, C).Interior.ColorIndex = 15
Next C

' ---------------------------------------------
' - Clean up pointers
' - Turn screen updating back on

Set curCell = Nothing
Set testCell = Nothing
Application.ScreenUpdating = True
End If
End Sub

Sub FixHeader()
Rows("1:1").Select
With Selection
With .Font
.Name = "Arial Narrow"
.Size = 10
.Bold = True
End With
.Rows.AutoFit
.WrapText = True
End With
End Sub


Sub SetFont()
Cells.Select
With Selection.Font
.Name = "Courier New"
.Size = 10
End With
Selection.RowHeight = 12
Cells(1, 1).Select
End Sub
-----------------------------------------------------------------------------------------------

 

[PeteCresswell]

Here's the whole enchilada.  

As stated before, I find it quite useful when people call me for data,
I run a query, and paste same into a .XLS.

Obviously, this is a continually-evolving microapplication.

If anybody is interested in getting the latest-and-greataest, ping me
(pCresswell at SEIC fullstop com) and I'll flip you a .XLS.