I played around with some test data and this _seemed_ to work ok.
But test it much more thoroughly than I did.
In a General Module:
Option Explicit
Sub myAutoFitMergedCellRowHeight(myActiveCell As Range)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim OrigMergeArea As Range
Dim CurrCell As Range
Dim myActiveCellWidth As Single, PossNewRowHeight As Single
If myActiveCell.MergeCells Then
Set OrigMergeArea = myActiveCell.MergeArea
With myActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
myActiveCellWidth = myActiveCell.ColumnWidth
For Each CurrCell In OrigMergeArea
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = myActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub
Sub MakeMergeCellRange()
Dim myCell As Range
Dim myMergedCells As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets("sheet1")
On Error Resume Next
wks.Names("MyMergedCells").Delete
On Error GoTo 0
If myMergedCells Is Nothing Then
For Each myCell In wks.UsedRange.Cells
If myCell.MergeCells Then
If myCell.Address = myCell.MergeArea.Cells(1, 1).Address Then
If myMergedCells Is Nothing Then
Set myMergedCells = myCell
Else
Set myMergedCells = Union(myMergedCells, myCell)
End If
End If
End If
Next myCell
End If
If myMergedCells Is Nothing Then
'do nothing
Else
myMergedCells.Name = "'" & wks.Name & "'!MyMergedCells"
End If
End Sub
Then under the worksheet that you want this to happen (I used Sheet1 in the code
above), paste this:
Option Explicit
Private Sub Worksheet_Calculate()
Dim myCell As Range
Dim myMergedCells As Range
If Me.UsedRange.Cells.MergeCells = False Then
'no merged cells
Else
On Error Resume Next
Application.EnableEvents = False
Set myMergedCells = Me.Range("myMergedCells")
Application.EnableEvents = True
On Error GoTo 0
If myMergedCells Is Nothing Then
'time to rebuild list
Application.EnableEvents = False
Call MakeMergeCellRange
Application.EnableEvents = True
Set myMergedCells = Me.Range("myMergedCells")
End If
End If
Me.Rows.AutoFit
If myMergedCells Is Nothing Then
'do nothing
Else
Application.ScreenUpdating = False
For Each myCell In myMergedCells
Call myAutoFitMergedCellRowHeight(myCell)
Next myCell
Application.ScreenUpdating = True
End If
End Sub
Each time the worksheet calculates, it'll resize the rows. And it'll cycle
through the merged cells trying to autofit each of those, too.
If you decide you want to add more merged areas to the worksheet, you can delete
the name "MyMergedCells" via:
the Insert|Names|Define dialog.
A new name will get created with the next calculation and it'll include the
merged cells.
(a side benefit is that if you Edit|goto, select mymergedcells, you'll select
the merged cells.)
Now, honestly, I wouldn't ever use something like this. I'd resize manually and
be happy.
-)