Automatically Change Row Height with Merged Cells

Hi RWSM

I'm guessing that you have several (or many) merged cells in your file and want to autofit all of them.

You can simpy autofit the height of merged cells if they span only one row, using this (in Module1):

Sub AutofitRowHeight()
    Dim n As Long

    With ActiveSheet.UsedRange
        'reset all used rows
        For n = 1 To .Rows.Count + .Rows(1).Row - 1
            Rows(n).AutoFit
        Next n
    End With
End Sub

but that doesn't work with cells merged over columns (see purple cells D14:F16 in the attached file).

A fuller soulution is in the attached file where there's a single sheet with two buttons at the top:

1. an orangey one labelled "Autofit merged ranges per row (add border)"  - which will do that plus autofit any non-merged cells with Word Wrap (like the green one) but ignore any without Word Wrap (like the yellow one)
2. a light blue one to undo that and set rows heights to the default

There are also some cells with text (some of which can't be seen).

If you click on the orangey button, this code runs (with comments to explain what happens):

Sub AutofitMergedColumns()

    Dim m As Long, n As Long, p As Long
    Dim ColWdth As Double, RwHt As Double, MaxHt As Double, MrgWdth As Double
    Dim MrgRng As Range, UsdRng As Range, FreeCol As Long

    ' hide actions
    Application.ScreenUpdating = False
    With ActiveSheet.UsedRange
        ' find first free column to right, allowing for any blank columns
        FreeCol = .Columns.Count + .Columns(1).Column
    End With

    Set UsdRng = ActiveSheet.UsedRange

    ' loop down used range
    With UsdRng
        For m = 1 To .Rows.Count
           'if the row isn't hidden or empty...
            If Not .Parent.Rows(.Cells(m, 1).Row).Hidden _
            Or WorksheetFunction.CountA(.Rows(m)) > 0 Then
              '... reset then work out maximum row height
              MaxHt = 0
              ' loop across row
              For n = 1 To .Columns.Count ' To 1 Step -1
                If Len(.Cells(m, n).Value) > 0 Then
                  'for any merged wrapped cells...
                  If .Cells(m, n).MergeCells = True Then
                    Set MrgRng = .Cells(m, n).MergeArea
                    ' collect column widths
                    With MrgRng
                      MrgWdth = 0
                      If .WrapText Then
                        For p = 1 To .Cells.Count
                            ' accumulate cell widths
                            MrgWdth = MrgWdth + .Columns(p).ColumnWidth
                        Next p
                        MrgWdth = MrgWdth + .Cells.Count * 0.66
                        'write value to row in free column of total width, autofit and get row height
                        With .Parent.Cells(.Row, FreeCol)
                          .Value = MrgRng.Value
                          .ColumnWidth = MrgWdth
                          .WrapText = True
                          .EntireRow.AutoFit
                          RwHt = .RowHeight
                          ' if > max height, replace value
                          MaxHt = Application.Max(RwHt, MaxHt)
                          ' undo write, resetting to Excel default width
                          .Value = vbNullString
                          .WrapText = False
                          .ColumnWidth = 8.43
                        End With
                        ' set height to maximum found and add border
                        .RowHeight = MaxHt
                        .Borders.LineStyle = xlContinuous
                      End If
                    End With

                    ' otherwise autofit any wrapped cells
                    ElseIf .Cells(m, n).WrapText = True Then
                        RwHt = .Cells(m, n).RowHeight
                        .Cells(m, n).EntireRow.AutoFit
                    If .Cells(m, n).RowHeight < RwHt Then .Cells(m, n).RowHeight = RwHt
                  End If
                End If
            Next n
        End If
    Next m
    'remove the free column
    .Parent.Columns(FreeCol).EntireColumn.Delete
    End With

    Application.ScreenUpdating = True
End Sub

It's based on some code I had before and essentially tries the merged texts in a new column, works out the maximum height needed for the row and applies that (for each used row).

It draws a border around the merged cells only so you can see the results - you can find by looking at the comments  then delete or comment out that line in the code.

The reset button runs this simple code:

Sub ResetRowHeight()
    Dim n As Long

    With ActiveSheet.UsedRange
        'reset all used rows
        For n = 1 To .Rows.Count + .Rows(1).Row - 1
            Rows(n).RowHeight = 15
        Next n
        ' clear borders
        .Borders.LineStyle = xlNone
    End With
End Sub

Both should work irrespective of how many merged or wrapped cells you have in the sheet (or sheets if you run the code on a chosen sheet or you loop through them).

Hope this works well for you. If so, please remember to mark this Answer as Selected.

Hello again RWSM,

There are 3 possibilities of merged cells: case 1) cells in the same row - ex: B3-C3-D3; case 2) cells in the same column - ex: A5-A6-A7; case 3) cells in adjacent rows and columns - ex: C5-D5-C6-D6.

In case 1, if you change the font size the row height will auto fit to the new size (increase or decrease of font size). In cases 2 & 3 auto fit will not adjust row height. Row height must be done manually. It may be possible to do this with VBA but I don't have the time to work out some code.

Update May 18/24

I've had some time to work out some code; here is another option to adjust row height in a merged range.

If the selected cell is not a merged range then nothing is done.

If the selected cell is a merged range then: 1) determine how many rows are in the merged area; 2)  determine the row number of the first row and last rows; 3) calculate the new row height using the selection's formatted font size; 4) if the new row height is calculated to be less than existing, then don't change the height; 5) resize the rows in the selection.

Sub AdjustRowHeight1()

' macro written by WillieD24 for teachexcel.com
' will adjust row height for multiple row merge area

Dim fRow As Long   ' first row of merged range
Dim rCount As Long   ' number of rows in merged range
Dim curHeight As Double   ' current row height
Dim newHeight As Double   ' new row height
Dim rF As Long, rL As Long   ' first and last rows of merged range
Dim fSize As Double   ' font size of merged range

    rCount = Selection.Rows.Count
'    MsgBox rCount
    fRow = Selection.Cells(1, 1).Row
'    MsgBox fRow

' check that selection; exit sub if selection is only a single row
If rCount = 1 Then Exit Sub

rF = fRow
rL = rF + (rCount - 1)
fSize = Selection.Font.Size
newHeight = fSize / rCount
' check new row height vs current row height; if less then exit sub
curHeight = Selection.RowHeight
If newHeight < curHeight Then Exit Sub
' resize row height
With Worksheets("Sheet1").Rows(rF & ":" & rL)
 .RowHeight = newHeight
End With

End Sub

Cheers   :-)