MergeCells, Merge, Autofit, Rech

Try this:

Sub AutoFitMergedCellRowHeight()
' modification of code originally posted by Jim Rech
Dim cell As Range, rng As Range
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
For Each cell In Selection
If cell.MergeCells Then
If rng Is Nothing Then
Set rng = cell.MergeArea(1)
Else
If Intersect(rng, cell.MergeArea(1)) Is Nothing Then
If cell.MergeCells Then
Set rng = Union(rng, cell.MergeArea(1))
End If
End If
End If
End If
Next
If rng Is Nothing Then Exit Sub
For Each cell In rng
cell.Select
If cell.MergeCells Then
With cell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
MergedCellRgWidth = 0
ActiveCellWidth = cell.ColumnWidth
For Each CurrCell In cell.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
Next
End Sub


--
Regards,
Tom Ogilvy

"Darin Kramer" wrote in message
...
Morning Tom,

TO answer your question, yes the original code does work on each of the
cells individually.

When selecting multiple occurences, your code works on the first
occurence, but not on the remaining. (takes the cursor to the last
occurence, but does not resize.

If i select all occurences, and run the original code, it does not work
at all.

Thanks so much, hoping we can resolve...

Big Thanks

D



*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!