Sub MergedAreaRowAutofit()
Dim j As Long
Dim n As Long
Dim i As Long
Dim MW As Double
Dim RH As Double
Dim MaxRH As Double
Dim rngMArea As Range
Dim rng As Range
Const SpareCol As Long = 26
Set rng = Rows("2:2")
With rng
For j = 1 To .Rows.Count
If Not .Parent.Rows(.Cells(j, 1).Row) _
.Hidden Then
If Application.WorksheetFunction _
.CountA(.Rows(j)) Then
MaxRH = 0
For n = .Columns.Count To 1 Step -1
If Len(.Cells(j, n).Value) Then
If .Cells(j, n).MergeCells Then
Set rngMArea = _
.Cells(j, n).MergeArea
With rngMArea
MW = 0
If .WrapText Then
For i = 1 To .Cells.Count
MW = MW + _
.Columns(i).ColumnWidth
Next
MW = MW + .Cells.Count * 0.66
With .Parent.Cells(.Row, SpareCol)
.Value = rngMArea.Value
.ColumnWidth = MW
.WrapText = True
.EntireRow.AutoFit
RH = .RowHeight
MaxRH = Application.Max(RH, MaxRH)
.Value = vbNullString
.WrapText = False
.ColumnWidth = 8.43
End With
.RowHeight = MaxRH
End If
End With
ElseIf .Cells(j, n).WrapText Then
RH = .Cells(j, n).RowHeight
.Cells(j, n).EntireRow.AutoFit
If .Cells(j, n).RowHeight < RH Then _
.Cells(j, n).RowHeight = RH
End If
End If
Next
End If
End If
Next
.Parent.Parent.Worksheets(.Parent.Name).UsedRange
End With
End Sub