Sub test()
On Error Resume Next
Dim coll As New Collection
Dim iRange As Range
Dim iCell As Range
   Set iRange = ActiveSheet.UsedRange
      For Each iCell In iRange
         If iCell.MergeCells Then
            coll.Add iCell.MergeArea.Address, iCell.MergeArea.Address
               If Err.Number = 0 Then
                  If iCell.Value = "" Then iCell.MergeArea.RowHeight = 0 Else iCell.MergeArea.EntireRow.AutoFit
               Else
                  Err.Clear
               End If
         End If
      Next
End Sub

Sub test()
On Error Resume Next
Application.ScreenUpdating = False
Dim coll As New Collection
Dim iRange As Range
Dim iCell As Range
Set iRange = ActiveSheet.UsedRange
For Each iCell In iRange
If iCell.MergeCells Then
coll.Add iCell.MergeArea.Address, iCell.MergeArea.Address
If Err.Number = 0 Then
If iCell.Value = "" Then
iCell.MergeArea.RowHeight = 0
Else
y = iCell.MergeArea.ColumnWidth
Set sh = Sheets.Add
With sh.Cells(1, 1)
  .HorizontalAlignment = iCell.MergeArea.HorizontalAlignment
  .VerticalAlignment = iCell.MergeArea.VerticalAlignment
  .WrapText = True
  .ColumnWidth = y * iCell.MergeArea.Columns.Count
  .Value = iCell.Value
  .EntireRow.AutoFit
  x1 = .RowHeight
End With
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
iCell.MergeArea.RowHeight = x1 / iCell.MergeArea.Rows.Count
End If
Else
Err.Clear
End If
End If
Next
Application.ScreenUpdating = True
End Sub