View Single Post
  #2 (permalink)  
Old March 1st, 2006, 07:11 PM
krechet krechet is offline
Registered User
Join Date: Mar 2006
Location: , , .
Posts: 1
Thanks: 0
Thanked 0 Times in 0 Posts

If you didn't find the solution yet, try this code for autofit merged cells.
I started with the same code as you found on the web and ended with complete redo.
 It is much easier on the worksheet
 it doesn;t incert or delet anything and leaves no trace/garbage anywhere.

Private Sub autoFit_Row_w_Merged_Cells(Target As Range, Optional addHeight As Double = 1)
    ' Autofits merged cells in the row.
    ' Fixes Excel bug in fitting
    ' Does this FAST
    ' created by Shura Krechetov, 2006,
    If ActiveSheet.ProtectContents Then
        MsgBox ("worksheet is protected. Can not do anything")
        Exit Sub
    End If
    'go over all all the merged ranges
    Dim r As Range, c As Range
    Dim ReqdHeight As Double
    ReqdHeight = 0
    Set r = Target.Cells(1, 1).EntireRow
    Dim col As Integer, colMax As Integer
    col = Target.Cells(1, 1).Column
    colMax = col + Target.Columns.Count - 1
    Do While col < colMax
        With r.Cells(1, col)
            If .MergeCells And .WrapText Then
                ' autofit row here

                ' calculate width of current merged area
                Dim mergedWidth As Double, mergedRange As Range
                Set mergedRange = .MergeArea
                mergedWidth = mergedRange.Width ' in points

                'unmerge cells
                .MergeCells = False
                'save the column width for the future recovery
                Dim tempColWidth As Double
                tempColWidth = .ColumnWidth

                ' make current column as wide as merged area
                ' one would ask why I convert from points (width)
                ' to characters (columnwidth) and back
                ' Apparently measurement in Columnwidth is much less accurate and
                ' I had a lot of problem matchin widthes with columnwidth
                ' Also Width property is applicable to therange and there is no
                ' need to cycle over all cells
                .ColumnWidth = points2char = 0.1905 * p - 0.7139 'Convert from points to "characters"
                ' fit it

                'save height for the moment look for maximum over the row
                If .RowHeight > ReqdHeight Then ReqdHeight = .RowHeight

                'recover current column width
                .ColumnWidth = tempColWidth

                mergedRange.MergeCells = True
                .EntireRow.RowHeight = Application.Max(ReqdHeight / mergedRange.Rows.Count + 0.5, 12.75) + addHeight
                'go to the next cell after merged area
                col = col + mergedRange.Columns.Count
                col = col + 1
            End If
        End With
End Sub

Reply With Quote