VBA Autofit Merged Cells - Too high!

[viviclemente]

Hi everyone,

Apologies if this is somewhere buried in the forum, but I need to make some merged cells autofit.
I found the code below, which works.. but the cells then become too high! The cells come out at about double the height of what I need them to be. Can you help?

Thanks!

Public Sub AutoFitAll()

Call AutoFitMergedCells(Range("e11:k11"))
Call AutoFitMergedCells(Range("e13:k13"))
Call AutoFitMergedCells(Range("l10:s10"))

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("Topics")
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

 

[viviclemente]

Can anyone help?

 

[gallen]

It gets confusing. I've commented every line to show what (I think) it is doing. Check and see if it's what it SHOULD be doing and which line(s) is causing the issues

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("Topics")
        oldWidth = 0
        
        For iPtr = 1 To oRange.Columns.Count
         'This will just end up with a single number that is the total of all the column widths. This is then over-written in the next line so why?
            oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
        Next iPtr
        
        ' You then change the oldWidth value so the line above is pointless
        oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth
        
        'unmerge a merged range
        oRange.MergeCells = False
        
        'set new width to equal a value in a cell?
        newWidth = Len(.Cells(oRange.Row, oRange.Column).Value)
        
        'Store the width  cell ZZ1
        oldZZWidth = .Range("ZZ1").ColumnWidth
        
        'Set ZZ1 to equal part of Cells(oRange.Row, oRange.Column)
        .Range("ZZ1") = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth)
        
        'Wrap text in ZZ1
        .Range("ZZ1").WrapText = True
        
        
        'Set the width of column ZZ to the value in oldWidth variable which is .Cells(1, oRange.Column).ColumnWidth .Cells(1, oRange.Column + 1).ColumnWidth
        .Columns("ZZ").ColumnWidth = oldWidth
        
        'set all cells in row to autofit
        .Rows("1").EntireRow.AutoFit
        
        'Set variable newHeight to = height of row 1 divided by number of rows oRange. Confusing
        newHeight = .Rows("1").RowHeight / oRange.Rows.Count
        
        'Set all rows in oRange to newHeight?? If so then just use oRange.RowHeight = newHeight
        .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight
        
        'Merge All cells in oRange?
        oRange.MergeCells = True
        
        'Wrap text of newly merged area
        oRange.WrapText = True
        
        'Delete value in ZZ1
        .Range("ZZ1").ClearContents
        
        'Set column of ZZ to oldZZWidth
        .Range("ZZ1").ColumnWidth = oldZZWidth
    End With


End Sub