Excel VBA Autofit Merged Cells

Question

Dear Stackoverflow users,

For a project i would like to adjust the height of a merged row to fit the contents.

I found the following code on "extendoffice.com". (https://www.extendoffice.com/documents/excel/2342-excel-autofit-row-height-merged-cells.html?page_comment=3)

The code looks clean and good, but i can't get it to work correctly, i think it's due to the different sizes of the columns. The height is just always way to large.

I already tried to get a constant to divide the outcome by 2 or another factor, but this is not working.

Could you a look and give me guidance how to solve the issue i'm encountering that the height is way larger than necessary.

The Example File: Example File

The Code:

    Option Explicit

Public Sub AutoFitAll()

  Call AutoFitMergedCells(Range("B4:K4"))
  Call AutoFitMergedCells(Range("B5:K5"))
  Call AutoFitMergedCells(Range("B6:K6"))

End Sub

Public Sub AutoFitMergedCells(oRange As Range)
  Dim tHeight As Integer
  Dim iPtr As Integer
  Dim oldWidth As Single
  Dim oldZZWidth As Single
  Dim newWidth As Single
  Dim newHeight As Single
  With Sheets("Lead")
    oldWidth = 0
    For iPtr = 1 To oRange.Columns.Count
      oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
    Next iPtr
    oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth
    oRange.MergeCells = False
    newWidth = Len(.Cells(oRange.Row, oRange.Column).Value)
    oldZZWidth = .Range("ZZ1").ColumnWidth
    .Range("ZZ1") = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth)
    .Range("ZZ1").WrapText = True
    .Columns("ZZ").ColumnWidth = oldWidth
    .Rows("1").EntireRow.AutoFit
    newHeight = .Rows("1").RowHeight / oRange.Rows.Count
    .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight
    oRange.MergeCells = True
    oRange.WrapText = True
    .Range("ZZ1").ClearContents
    .Range("ZZ1").ColumnWidth = oldZZWidth
  End With
End Sub

Thanks in advance!

Regards, Dubblej

Answer 1

So I gave it a try as per Allen Wyatt's suggestion here.

He suggested using a helper column, in my case, column P (shouldn't be immediately adjacent) and have a cell with identical formatting (except for merging) pointing at the top left cell of your merged range.

So if you had the following in merged range B4:K4:

Which originally was compressed like so:

In P4 put the formula =B4

Then in a standard module put

Option Explicit

Sub Autofit()

    ActiveSheet.Range("P4").Rows.Autofit

End Sub

Seems to work.

Answer 2

This problem seems easy, but you can see that there are several exceptions to use. Actually necessary code is more than 10 times the size of simple code.

I made add-in for Auto fit row height of multiple merged cells. Please use this, if you want to autofit row hight. ［Release Ver2.6 · toowaki/AutoFitRowEx · GitHub］ https://github.com/toowaki/AutoFitRowEx/releases/tag/2.6.2