Automatically adjust height of merged cell

When you double-click between a line and a line in Excel
The height of the cell is automatically adjusted.

However, in a merged cell
Height can not be adjusted automatically.

Even when a merged cell is applied to
"Format Cells" - "Display Fully Wrap",
The height is not automatically adjusted.
In case for printing in this state, necessary parts will be missing.

I am making this possible with VBA.
I came up with an easy way using worksheets.

The Roughly flow of the code as follows

① Create a sheet "macro180724a" for working.
② Input the string in the merged cell
to the cell A1 not merged in the working sheet.
③ Make the width of cell A1 the same as
the width of the whole merged cell.
④ Automatically adjust the height in cell A1 and
Obtain cell height.
⑤ Set this height to the original merged cell.

Code here

Sub macro180724a()
'Automatically adjusts height of merged cell
'Before running this macro
'Select the range you want to adjust

    Application.ScreenUpdating = False
   
    Dim obj As Object
    Dim i As Integer
    Dim c As Integer
    Dim width1 As Single
    Dim rng1 As Range
    Set rng1 = Selection
   
    Dim sh1 As Worksheet
    Sheets.Add.Name = "macro180724a"
    Set sh1 = Sheets ("macro180724a")
    With sh1.Cells(1, 1)
        .WrapText = True
        .ShrinkToFit = False
        Rows(.Row).EntireRow.AutoFit
    End With
   
    For Each obj In rng1
        'Only merged cells
      If obj.MergeCells = True Then
            sh1.Range("A1") = obj.MergeArea.Cells(1, 1).Text
            For i = 1 To obj.MergeArea.Count
                If obj.MergeArea.Item(i).Column > c Then
                    width1 = width1 + obj.MergeArea.Item (i).ColumnWidth
                    c = obj.MergeArea.Item(i).Column
                Else
                    i = obj.MergeArea.Count
                End If
                If i = obj.MergeArea.Count Then
                    sh1.Cells(1, 1).ColumnWidth = width1
                    Rows(sh1.Cells(1, 1).Row).EntireRow.AutoFit
                    c = 0
                    width1 = 0
                End If
            Next i
           
            With obj
                .WrapText = True
                .ShrinkToFit = False
                .RowHeight = sh1.Cells(1, 1).RowHeight
            End With
           
        End If
    Next
   
    Application.DisplayAlerts = False
    sh1.Delete
    Application.DisplayAlerts = True
   
    Application.ScreenUpdating = True
End Sub

Execute the above code in the state of the image below

Result：

I tried the above code several times.
Please check the result
because it may be set to a height that is high by one line
depending on the input string or cell width.