Merged cell auto row height revisited

[RealmSteel]

I seem to hit a deadend in the following topic, but came across another
idea.
http://groups.google.com/group/micr...?lnk=gst&q=Realmsteel&rnum=2#69ea9a0b49426a28

What I am trying to do is make a merged cell automatically adjust the
row height if the text is longer than the cell width.
The merged cells are all formatted to wrap text.

Here is what the code looks like:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
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

The problem with this code is that it only works when you first select
the cell.
What we have to do is type the text, navigate away and reselect the
cell.

I want it to run it's routine when the enter key is pressed or you
navigate away from the active cell.

How can this code be changed to accomplish this?

Another option would be to have it continuously scan a range or column.
Above row 12, the cells are not merged, so I don't know if this would
be a problem.

 

[RealmSteel]

Another thought I had was to have the code run on the previously active
cell.

That would cover about any way the user could do to navagate away.
If they click a cell somewhere else in the worksheet it would go back
to tha last active cell and run the code.

Is there a way to do that?

 

[thesquirrel]

I had a similar problem on a current project that I am working on...
<what a mess>.

I have a daily report that I migrated from Word to Excel to make math
functions easier to work with, however in doing so, I lost the ability
to manage the size of the cells in the Word document tables. The
solutions in my case required the need to format individual characters
as well as have bullet pointed lists and tables within the cells... On
top of that, the cells were merged to a single row and about 80 columns
(auto row height was busted with the merged).

I quickly realized that this was not going to be easy, so I resorted to
inserting Word Document objects in to my main template worksheet. I
thought everything was great, it allowed me to do all the things that I
needed to do within the objects however I could not get the cells to
grow and shrink with the size of the OLEObjects initially.

Here is how I dealt with it...

Each OLEObject was assigned a macro as such:

Public Sub ObjectMsg1()
'This is the function for the Daily Project Status
' Object 7

'flip the flag to resize the rows
boolResizeDaily = True

ActiveSheet.OLEObjects(3).Activate

End Sub

All this does is that when the OLEObject is clicked, its activated. I
did this to activate another sub when the user exits the OLEObject
later. When the user clicks out of hte object I have the following
code in the worksheets code page:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'a bunch of code

If boolResizeDaily = True Or _
boolResizeFailed = True Or _
boolResizeResults = True Or _
boolResizeNotes = True Or _
boolResizeMeeting = True Or _
boolResizeDayShift = True Or _
boolResizeNightShift = True Or _
boolResizeThirdShift = True Then ResizeRows (x)

'the rest of my code
End Sub

This runs the Resize Rows sub (I pass the x variable to make sure the
ResizeRows sub doesn't show up in the Tools>Macro>Macros list). Here
is a snippet of the ResizeRows sub:

Public Sub ResizeRows(x As Byte)

Application.ScreenUpdating = False

With ActiveSheet
Dim RowHeight As Double

'unlock the sheet for resizing
.Unprotect "locked"


'We need to check to see which row needs to be resized
If boolResizeDaily = True Then
With .OLEObjects(3)

'Size the Box to the smallest so we can shrink it
if need be
' before enlarging it
.Height = 1

'At this point we need to find out if the height
of the
' Word Object is larger than the max row height
and
' incorporate more rows to help handle it
Dim DailyHeight As Double
DailyHeight = .Height
End With

'Test Daily Height to make sure its not too large
If DailyHeight > 2400 Then
MsgBox "Dood, your entry here is crazy long." &
vbCrLf & _
"Lets shorten it up and get it together!",
vbCritical, "Nice Work Bro"
.OLEObjects(3).Activate

Exit Sub
End If

RowHeight = Round(DailyHeight / 6, 0)
.Rows("61:66").RowHeight = RowHeight

.OLEObjects(3).Width = 508.5
End If
'more of my code

End Sub

I utilize 6 rows to evenly spread the total height of the rows for
smooth scrolling purposes, since many of hte entries in the OLEObjects
extend to RowHeights of 500 to sometimes 2000.

Not sure if this has anything to do with the OP's problem, but this is
similar.

theSquirrel

 

[RealmSteel]

The code posted in the following message seems to work.
If I have troubles, I'll try thesquirrel's.

Not having much experience with VBA, I get to a point where I don't
know what to modify to fit my application.

http://groups.google.com/group/micr...ramming/browse_thread/thread/6f52cf0554a83f36