Excel adjust height of merged cells automatically

0
votes

I have a little problem in excel. I not experienced with excel macros and would be grateful for some help. I am trying to find a macro which ajustes the height of a merged cell to fit its content. automatically. I found something with which could do that for cells in several columns but not for several rows and also not automatically: 

 Sub AutoFitMergedCellRowHeight()
 Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
 Dim CurrCell As Range
 Dim ActiveCellWidth As Single, PossNewRowHeight As Single
 Dim iX As Integer

 If ActiveCell.MergeCells Then
    With ActiveCell.MergeArea
         If .Rows.Count = 1 And .WrapText = True Then
             Application.ScreenUpdating = False
             CurrentRowHeight = .RowHeight
             ActiveCellWidth = ActiveCell.ColumnWidth
             For Each CurrCell In Selection
                 MergedCellRgWidth = CurrCell.ColumnWidth + _
                    MergedCellRgWidth
                 iX = iX + 1
             Next
             MergedCellRgWidth = MergedCellRgWidth + (iX - 1) * 0.71
             .MergeCells = False
             .Cells(1).ColumnWidth = MergedCellRgWidth
             .EntireRow.AutoFit
             PossNewRowHeight = .RowHeight
             .Cells(1).ColumnWidth = ActiveCellWidth
             .MergeCells = True
             .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
              CurrentRowHeight, PossNewRowHeight)
         End If
     End With
 End If

End Sub

The end result should look like this:enter image description here Thank you in advance.

3
excelvba
You should be able to follow a similar pattern for rows: if the cells are merged then unmerge them, autofit the first cell and note the fitted row height. Then remerge the cells and set the last cell height equal to the height you noted minus the height of all the other rows. – Tim Williams

3 Answers

4
votes

Something like:

Dim h, rng As Range
Set rng = Selection

With rng
    .UnMerge
    .Cells(1).EntireRow.AutoFit
    h = .Cells(1).RowHeight
    .Merge
    .EntireRow.AutoFit
    With .Cells(1).MergeArea
        .Cells(.Cells.Count).RowHeight = _
           .Cells(.Cells.Count).RowHeight + (h - .Height)
    End With
End With
3
votes

There is a much easier way of doing this if you allow the Excel sheet to do some of the heavy lifting for you.

The following example works in the common scenario that you have some cells that comprise several columns but only a single row (i.e. some columns are merged together on a single row). The usual problem is that the row height for wrapped text in the merged cell does not accomodate the height of the wrapped text in some circumstances (e.g. the result of a formula or database lookup gives a large and varying amounts of text)

To solve this, simulate single celled versions of the merged cells by doing the following in some columns that are not visible to the user:

  1. In a single cell that is on the same row as the merged cell, place an identical formulae or simply set the formulae equal to a reference to the merged cell.
  2. Do this for all merged cells.
  3. Make the width of the single cell versions equal to the width of each merged cell(s). You now have a set of single celled versions of the merged cells, on the same rows, but with the same column width.
  4. Name these single cells.

  5. Write a function that loops through all of these named single cell ranges and calls the following function for each: 

    Private Sub AutosizeLongFormInput(rng As Range)
    If Not rng.EntireRow.Hidden = True Then
        rng.EntireRow.AutoFit
    End If
End Sub

0
votes

What about this:

'rRang is range of cells which are merged together

Sub AutoFitRowMergedCells(rRang As Range)

Dim iColW As Integer, iColWold As Integer, I As Integer

iColW = 0

For I = 1 To rRang.Columns.Count
    iColW = iColW + rRang.Range("A" & I).ColumnWidth
Next I

rRang.UnMerge
iColWold = rRang.Range("A1").ColumnWidth
rRang.Range("A1").ColumnWidth = iColW
rRang.Range("A1").EntireRow.AutoFit
rRang.Range("A1").ColumnWidth = iColWold
rRang.Merge

End Sub