Merged Cells Autofit - code amendment

[roy]

Thanks to the help of Doug, have come across the coding below to deal
with autofit of a row that is merged across columns. My query is.....
Can the code below by MVP Jim Rech be edited to select a particular
group of cells only (i.e. a target range of rows 80:91 and a secondary
target of 100:105) and not any other cells, but also to work
automatically when user hits enter or by a macro button on the toolbar
?

Needs to run on XL97 btw


This 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




Many thanks in advance,
Roy.

 

[Tom Ogilvy]

Right click on the worksheet where you want this behavior and paste in code
such as this:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("80:91,100:105")) Is Nothing Then

Application.EnableEvents = False
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If Target.MergeCells Then
With Target.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = Target.ColumnWidth
For Each CurrCell In Target.MergeArea
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
Application.EnableEvents = True
End If
End Sub

 

[roy]

Hi Tom,

That didn't work for me either,(don't know why, but it just sat there
doing nothing), although nothing came up to say it wasn't working
either (i.e. a "bug" report). Have included a slightly emended version
of my initial query below if this helps clarify things at all ?

Many thanks Tom )



Sorry if this has been posted before, but have spent a fair bit of
time searching through the google pages, but didn't find quite the
right thing

I have a worksheet, which is about 4-5 pages long in total, that is
set to take all sorts of data entries (both numeric and text) that are
going to be anything from a 2-3 word entry up to quite a lengthy
string of words. The users entering this data will be using the "Alt +
Enter" method to simulate a carraige return. The problem I am having
is that the sheet needs to hold some form of "presentable" format when
either printed or viewed on screen and as such have had to set the row
heights to a uniform measurement to ensure a presence (albeit a rather
dubious one)of professionalism on the users behalf.

When all of their entries are fairly small (perhaps there are only two
or three lines of data in a cell) there is no problem as the end
result looks good (all cells aligned , centred, e.t.c.)but as soon as
they go "over the limit" of the set row height, the rest of the text
is then hiden under the cell border of the next cell below it.

Is there any way that I can use a macro that will automatically
correct the row height (perhaps as soon as the user hits "enter" to go
to the next cell), so that those cells, and those cells only, that due
to the quantity of text entered need to exceed the pre-set height (say
size 36 for example), will automatically be adjusted to a row height
that then shows all data entered ?

Due to the nature of the sheet itself and the numeric data in other
cells higher up the sheet, I need this to happen to only 2 specific
"ranges" of rows (for example rows 80 to 91 inclusive and for rows 100
to 105 inclusive).

Would like to express my most sincerest thanks in advance for any help
that you may be able to give with this headache.


Best regards,
Roy.

 

[steve]

Roy,

I played with Tom's code in Excel97 and made some minor changes.
It will now work provided your merged cells are on the same row ONLY.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("80:91,100:105")) Is Nothing Then

Application.EnableEvents = False
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If Target.MergeCells Then
With Target
If .Rows.Count = 1 Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = Target.ColumnWidth
For Each CurrCell In Target
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
Application.EnableEvents = True
End If
End Sub

 

[lcoreyl]

*Right click on the worksheet where you want this behavior and paste
in code
such as this:

Private Sub Worksheet_Change(ByVal Target As Range)
blah blah....*

Thanks Tom, you da man!!

This forum is great!!!!!!!

 

[lcoreyl]

when deleting the contents of a merged cell this code errors at

With Target.MergeArea

it says "application defined or object defined error" when you mouse
over this line of code in debug mode. I assume that for Target to work
there has to be something in the cell, since that is the behavior. I
thought Target was supposed to be like a range, however.

anyone??

 

[Dave Peterson]

Try:
With Target(1).MergeArea

And change one more line:
from:
For Each CurrCell In Target.MergeArea
to:
For Each CurrCell In Target(1).MergeArea

 

[lcoreyl]

TRY:
WITH TARGET(1).MERGEAREA

AND CHANGE ONE MORE LINE:
FROM:
FOR EACH CURRCELL IN TARGET.MERGEAREA
TO:
FOR EACH CURRCELL IN TARGET(1).MERGEAREA

That's it! thanks!