asked on

VBA – How to autofit row height with merged cells?

I found the below code and it works, but it adds extra space to the column height. How can I remove the extra space?

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("Slide 3")
    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

Open in new window

Shums Faruk

Hi,

1. Right-click on the sheet tab, and paste the following code on the worksheet module. Note: Only one Worksheet_Change event is allowed in each worksheet module.
2. Change the range value from “A2”, to the range on your worksheet.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim MergeWidth As Single
Dim cM As Range
Dim AutoFitRng As Range
Dim CWidth As Double
Dim NewRowHt As Double
Dim str01 As String
str01 = Range("A2").value 'Change your cell value here

  If Not Intersect(Target, Range(str01)) Is Nothing Then
    Application.ScreenUpdating = False
    On Error Resume Next
    Set AutoFitRng = Range(Range(str01).MergeArea.Address)

    With AutoFitRng
      .MergeCells = False
      CWidth = .Cells(1).ColumnWidth
      MergeWidth = 0
      For Each cM In AutoFitRng
          cM.WrapText = True
          MergeWidth = cM.ColumnWidth + MergeWidth
      Next
      'small adjustment to temporary width
      MergeWidth = MergeWidth + AutoFitRng.Cells.Count * 0.66 'Adjust the row height here
      .Cells(1).ColumnWidth = MergeWidth
      .EntireRow.AutoFit
      NewRowHt = .RowHeight
      .Cells(1).ColumnWidth = CWidth
      .MergeCells = True
      .RowHeight = NewRowHt
    End With
    Application.ScreenUpdating = True
  End If
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

Shums Faruk

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

kbay808

ASKER

For the first code, I'm getting the following error for line "If Not Intersect(Target, Range(str01)) Is Nothing Then".

"Run-time error 1004"
Method 'Range' of object '_Worksheet' failed

Shums Faruk

Try the second one

kbay808

ASKER

The second one works, but how can I make a function so that I can call it with a range?

Shums Faruk

You cannot call function. Functions are mainly used to covert formulas. You can create a Command Button on the sheet to click for running above code

kbay808

ASKER

Thank you

Shums Faruk

Ok when you name the range of Merged Cell and try below code in worksheet event, it works:
I Merged A2:C3 expanded row height to 45 and named it ProbCell.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim MergeWidth As Single
Dim cM As Range
Dim AutoFitRng As Range
Dim CWidth As Double
Dim NewRowHt As Double
Dim str01 As String
str01 = "ProbCell"

  If Not Intersect(Target, Range(str01)) Is Nothing Then
    Application.ScreenUpdating = False
    On Error Resume Next
    Set AutoFitRng = Range(Range(str01).MergeArea.Address)

    With AutoFitRng
      .MergeCells = False
      CWidth = .Cells(1).ColumnWidth
      MergeWidth = 0
      For Each cM In AutoFitRng
          cM.WrapText = True
          MergeWidth = cM.ColumnWidth + MergeWidth
      Next
      'small adjustment to temporary width
      MergeWidth = MergeWidth + AutoFitRng.Cells.Count * 0.66
      .Cells(1).ColumnWidth = MergeWidth
      .EntireRow.AutoFit
      NewRowHt = .RowHeight
      .Cells(1).ColumnWidth = CWidth
      .MergeCells = True
      .RowHeight = NewRowHt
    End With
    Application.ScreenUpdating = True
  End If

End Sub

Open in new window

kbay808

ASKER

How do I target an array on a different sheet?

ar = Array("C10", "C12", "C14", "C16", "C18", "C20")

Open in new window

I Tried

ar = Array(Sheet4.Range("A4"), Sheet4.Range("A10")

Open in new window

kbay808

ASKER

Never mind. I figured it out

Sub FixMerged() 'Excel VBA to autofit merged cells
Dim mw As Single
Dim cM As Range
Dim rng As Range
Dim cw As Double
Dim rwht As Double
Dim ar As Variant
Dim i As Integer

With Sheet4
    Application.ScreenUpdating = False
    'Cell Ranges below, change to suit.
    ar = Array("A4", "A7", "A10", "A13", "A16", "A20")
    
    For i = 0 To UBound(ar)
    On Error Resume Next
    Set rng = Range(Range(ar(i)).MergeArea.Address)
    rng.MergeCells = False
    cw = rng.Cells(1).ColumnWidth
    mw = 0
    For Each cM In rng
    cM.WrapText = True
    mw = cM.ColumnWidth + mw
    Next
    mw = mw + rng.Cells.Count * 0.66
    rng.Cells(1).ColumnWidth = mw
    rng.EntireRow.AutoFit
    rwht = rng.RowHeight
    rng.Cells(1).ColumnWidth = cw
    rng.MergeCells = True
    rng.RowHeight = rwht
    Next i
    Application.ScreenUpdating = True
End With
End Sub

Open in new window

Shums Faruk

I was about to reply you, this code will run on any active sheet, you just need to change range to array. :)

Shums Faruk

Just be careful, "with sheet", it will run only on that particular sheet.