Solved: AutoFit - Expand Cell With Data Entered?

[tonyrosen]

Possible?

Similar to this?


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target(1, 1), [A:A]) Is Nothing Then Exit Sub
Target(1, 1).EntireColumn.Autofit
End Sub

[mvidas]

Hi Tony,

Try the following, it should do what you want (though I am slightly confused as to what you are after). If its not perfect, let me know what else you would like it to do!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ColWid As Double, CLL As Range
Application.ScreenUpdating = False
For Each CLL In Target.Cells
ColWid = CLL.ColumnWidth
CLL.Columns.AutoFit
If CLL.ColumnWidth < ColWid Then
CLL.EntireColumn.ColumnWidth = ColWid
End If
Next
Application.ScreenUpdating = True
End SubMatt

[tonyrosen]

Cursory glance tells me no ...

Let's say "Row 14" is the 'answer to a question' on my Worksheet. That answer could be taller than the row - and I'd like the row to "autofit" the contents so I can read the entire cell without touching the row heights ... in other words, have the row's height grow all by itself.

[mvidas]

Oh, you want row height. Sorry, I thought you wanted the column to change in size if the text entered was bigger than the current size (as the example you had changes the width of column A). Try the following (same idea as before, just changed it to row height instead of column width):Private Sub Worksheet_Change(ByVal Target As Range)
Dim RowHgt As Double, CLL As Range
Application.ScreenUpdating = False
For Each CLL In Target.Cells
RowHgt = CLL.RowHeight
CLL.Rows.AutoFit
If CLL.RowHeight < RowHgt Then
CLL.EntireRow.RowHeight = RowHgt
End If
Next
Application.ScreenUpdating = True
End SubMatt

[tonyrosen]

Is there a way to make that work on merged cells?

[mvidas]

That is a tough question! Autofit doesn't work on merged cells unfortunately. Luckily, a workaround has been created by Brad Yundt (byundt). Take a look at his solution here:
http://www.experts-exchange.com/Q_21266648.html#12994257
I have used this in the past, and works exactly as desired.

One thing you might want to do is get rid of those merged cells! They confuse VBA to no end, and just have more trouble than they're worth a lot of the time. You might want to take a look at the "Center across selection" option for Horizontal Alignment of a cell.
To use this, just to give you a quick example, create a new sheet and select cells A1:C1. Go to Format / Cells, then the Alignment tab, and change the horizontal alignment to 'center across selection'. Click ok. Now, in A1, type something. It is centered across those cells, even though they're not merged. It won't help you in this autofit issue, but it does alleviate a lot of the other problems that stem from merged cells.

Matt

[tonyrosen]

That code works PERFECTLY ... reinforces the "Some people have way too much time on their hands."

[mvidas]

That code works PERFECTLY ... reinforces the "Some people have way too much time on their hands."
Ha! See, to me that reinforces the "that guy is a friggin genius" :)

[tonyrosen]

"Genius" usually equals "Too Much Free Time"

[cleturno]

I see that the solution works, but it also throws you out into never never land. When you use the enter you need to hit it one extra time to get it to work. Now you try to use the tab key and you are out there in the boonies.

[byundt]

cleturno,
I just updated the code in the Experts-Exchange link to handle the case of the merged area being more than one row.

The original code was designed for several columns merged horizontally, but it gave you a blank space at the top of the newly sized merge area if there were more than one row. With this tweak colCopy.ClearContents
i = Target.Parent.UsedRange.Rows.Count
For Each rw In Target.MergeArea.Rows
'Round row height up to 0.5 points, minimum of 12.75 points
rw.RowHeight = Application.Max(ReqdHeight / Target.MergeArea.Rows.Count + 0.49, 12.75)
Next
If ReqdHeight >= 409.5 Then MsgBox "Warning! Text is truncated because maximum merged cell " & _
"height is 409.5 points"
Application.ScreenUpdating = True
End Sub
the code now handles the multi-row merge area correctly. The limit of 409.5 point row height is still a limitation, however.

I was not able to repeat your problem with the Tab or Enter key throwing the user into neverland. Could you describe it in more detail?

Brad

[cleturno]

After the user enters the data and presses enter the change event occurs the selection box moves all the way to the farthest column in the table makes the changes then resizes appropriately. You then have to press enter again for the selection box to go to the cell below. If you hit tab instead of enter it will take you to the farthest column in the worksheet and you have to scroll back to your working range.

I am running 2003. Don't know if that will make a huge difference, but wanted to mention it.

Thanks for all your help with this

[cleturno]

If you watch the address through the execution the selection switches. Lets say I am in cell C11 and I enter the data and press enter. The cell address changes to IV11, then if I press enter again it will take me to the next row. When I hit tab the address also changed, but it will not return me to the previous cell. I am calling this from the Worksheet_Change Event.

[byundt]

cleturno,
Try the following Worksheet_Change sub instead. It captures the next selected cell before performing the "AutoFit". Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range
If Not Target.Cells(1, 1).MergeCells Then Exit Sub

Set cel = ActiveCell
On Error Resume Next
Application.EnableEvents = False
AutoFitMergedCells Target
cel.Activate 'Without this statement, cursor ends up in column IV
Application.EnableEvents = True
On Error GoTo 0

End SubBrad

[cleturno]

It is still leaving me at the end of the worksheet. Here is the code that I am using:

This is in my workbook:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range
If Not Target.Cells(1, 1).MergeCells Then Exit Sub
Set cel = ActiveCell
On Error Resume Next
Application.EnableEvents = False
AutoFitMergedCells Target
cel.Select 'Without this statement, cursor ends up in column IV
Application.EnableEvents = True
On Error GoTo 0
End Sub


This is the code from your module:


Sub AutoFitMergedCells(Target As Range)
'AutoFits a merged cell range, even though it is technically impossible
Dim MergedWidth As Double, ReqdHeight As Double
Dim cel As Range, celTemp As Range, col As Range, colCopy As Range, rg As Range
Dim Mergers As New Collection
Dim i As Long, nMerge As Long, nRow As Long
Set rg = Target.Cells(1, 1)
If Not rg.MergeCells Then Exit Sub
Application.ScreenUpdating = False
'Identify all the merged ranges in this row
nRow = rg.Row
With Target.Parent 'The worksheet containing the range Target
For i = 1 To 256
If .Cells(nRow, i).MergeCells And .Cells(nRow, i).WrapText Then
nMerge = nMerge + 1
Mergers.Add Item:=.Cells(nRow, i).MergeArea
i = i + .Cells(nRow, i).MergeArea.Columns.Count - 1
End If
Next
Set colCopy = .Columns(256) '.Insert 'Insert an empty column
Set celTemp = colCopy.Cells(nRow, 1)
End With
For i = 1 To nMerge 'Loop through all the merged areas on this row
Set rg = Mergers(i)
With rg
MergedWidth = 0
Set cel = .Cells(1, 1)
For Each col In .Columns
MergedWidth = col.Width + MergedWidth 'Measured in points
Next col

.MergeCells = False
colCopy.ColumnWidth = 0.1905 * MergedWidth - 0.7139 'Convert from points to "characters"
cel.Copy
celTemp.PasteSpecial xlPasteValues
celTemp.PasteSpecial xlPasteFormats
.MergeCells = True

celTemp.EntireRow.AutoFit

'For some reason, celTemp.EntireRow.Height changes when .MergeCells=True
If celTemp.EntireRow.Height > ReqdHeight Then ReqdHeight = celTemp.EntireRow.Height
End With
Next
colCopy.ClearContents
i = Target.Parent.UsedRange.Rows.Count
For Each rw In Target.MergeArea.Rows
'Round row height up to 0.5 points, minimum of 12.75 points
rw.RowHeight = Application.Max(ReqdHeight / Target.MergeArea.Rows.Count + 0.49, 12.75)
Next
If ReqdHeight >= 409.5 Then MsgBox "Warning! Text is truncated because maximum merged cell " & _
"height is 409.5 points"
Application.ScreenUpdating = True
End Sub

[cleturno]

I can not get it to quit putting me at the end of the column even if I cel.Select, I have to hit enter twice to get it to put me back where I am supposed to be and tab just leaves me out at the IV column.

[mvidas]

cleturno,

Would you be able to post a sample file with it? Then describe going to cell __ and tell us the specific text you enter before pressing tab? I think that would help Brad a lot to see what is happening. I don't get the same behavior, though I may be testing it differently. With your sample and your instructions on how you cause the behavior, it will probably make things a bit easier.

[cleturno]

Here is the sample file

[mvidas]

You can attach it to the thread by clicking "Go Advanced" below the quick reply box, and using the menu on the reply page

[cleturno]

there she is

[cleturno]

If you enter enough text into the right column and get it to wrap you will see what I am talking about. I just don't know what is wrong with it

[cleturno]

If you enter enough text into the right column and get it to wrap you will see what I am talking about.

[cleturno]

If you enter enough text into the right column and get it to wrap you will see what I am talking about. Let me know if you are seeing the same thing I am.

[byundt]

cleturno,
You had Worksheet_Change subs both in the code pane for DOR worksheet and in ThisWorkbook code pane. The former did not include the fix for the tab key suggested above--but the latter one did. Unfortunately, the former is the one that runs automatically.

You can fix your problem by doing two things:
1) Rename the Worksheet_Change sub (on the code pane for worksheet DOR) to xWorksheet_Change (or else delete it entirely)
2) Change the declaration line of the other sub (in the ThisWorkbook code pane) to read Workbook_SheetChange. See code below.

As a result, the Worksheet_Change sub will no longer be triggered by events on that worksheet--but the Workbook_SheetChange sub will run, and entering a tab will take you to the adjacent cell after completing the autofit. 'This sub must be installed in the ThisWorkbook code pane. It won't work at all if installed anywhere else.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim cel As Range
If Not Target.Cells(1, 1).MergeCells Then Exit Sub
Set cel = ActiveCell
On Error Resume Next
Application.EnableEvents = False
AutoFitMergedCells Target
cel.Select 'Without this statement, cursor ends up in column IV
Application.EnableEvents = True
On Error GoTo 0
End SubBrad

[cleturno]

Thanks for all your help on this. I didn't realize that I was calling it in both places. I have got it working now and I am very grateful that you took the time to fix this for me.