How to AutoFit Row Height Merge Cells?

[putritersenyum]

Please, help me to AutoFit Row Height the contents on merge cells with wrap text. On the unmerge cell AutoFit Row Height works perfectly.

[dflak]

The following code adds up the column widths of the individually merged cells, unmerges the cell, resets the width of the first cell in the range to the combined width, autofits the row height of the single cell and remerges the cell.

The way I suggest you use this is to make up a macro like Test() and map it to a control key. Then you can select the cell and click on the control combination and the cell will be formatted.

Sub AutoFitMergedCellRowHeight(MyCell As Range)
    Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
    Dim CurrCell As Range
    Dim ActiveCellWidth As Single, PossNewRowHeight As Single
    
    ' Make the cell active
    MyCell.Activate
    ' Set the intial height to 0
    ActiveCell.RowHeight = 0
    
    ' If the cell is merged
    If ActiveCell.MergeCells Then
        ' With the merged area
        With ActiveCell.MergeArea
            ' If it is merged across more than one column
            If .Rows.Count = 1 And .WrapText = True Then
                Application.ScreenUpdating = False
                CurrentRowHeight = .RowHeight
                ActiveCellWidth = ActiveCell.ColumnWidth
                ' Add up the width of each of the cells in the merge
                For Each CurrCell In Selection
                    MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
                Next
                ' Unmerge the cells
                .MergeCells = False
                ' Make the singe cell the combined with
                .Cells(1).ColumnWidth = MergedCellRgWidth
                ' Autofit the cell
                .EntireRow.AutoFit
                
                PossNewRowHeight = .RowHeight
                .Cells(1).ColumnWidth = ActiveCellWidth
                ' Remerge the cells
                .MergeCells = True
                .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
                 CurrentRowHeight, PossNewRowHeight)
            End If
        End With
    End If
End Sub

Sub test()
AutoFitMergedCellRowHeight Selection
End Sub

[putritersenyum]

@ dflak, thanks a lot it works well. but please, help me to apply the change automatically without run macro sub (test) manually. And how to apply multiple selections?

[dflak]

I don't think I can make it automatic. To make it apply to multiple selections, try using the following code.

Sub test()
Dim cl As Range
For Each cl In seletction
    AutoFitMergedCellRowHeight cl
Next
End Sub

[putritersenyum]

I have tried for multiple selections, but it didn't work for me.

Sub test()
Dim cl As Range
For Each cl In selection
    AutoFitMergedCellRowHeight cl
Next
End Sub