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
---------------------------------------------------------

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
--------------------------------------------------------

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.

PeteCresswell wrote:
>
> 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
> ---------------------------------------------------------

--

Dave Peterson

On Oct 26, 10:41*am, Dave Peterson <peter...@verizonXSPAM.net> wrote:
> 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).

On Oct 26, 12:01*pm, PeteCresswell <petecr...@gmail.com> wrote:

> 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.

> > 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.

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.

--
Rick (MVP - Excel)

On Oct 26, 12:29*pm, "Rick Rothstein"
<rick.newsNO.S...@NO.SPAMverizon.net> wrote:
>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!

> >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.

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

--
Rick (MVP - Excel)

On Oct 26, 1:53*pm, "Rick Rothstein"
<rick.newsNO.S...@NO.SPAMverizon.net> wrote:
> 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
-----------------------------------------------------------------------------------------------

> 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.