autosizing column height of merged cell - for a range

[thomgreen]

I have workable code for outsizing the height of a merged cell. Unfortunately I need it to work for a range of cells. I did used the working code and put it inside a loop through the range of cells but receive an error. The working (individual cell) code is below and the error to the loop through range is below that:

WORKING CODE FOR INDIVIDUAL CELL:
Sub mergefit()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
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
Next
.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

ERROR WHEN ABOVE CODE IS PLACED IN A LOOP:
Run-Time error '1004';
Unable to set the ColumnWidth property of the Range class

Any help with this code would be GREATLY appreciated.

 

[byundt]

thomgreen,
You can't AutoFit a merged cell--so your existing code will fail. What you can do is copy the data to a new column which is the same width as your merged cells, then AutoFit that. Here's a sub that illustrates the procedure for a single row:

Note that it won't work past 409.5 points of row height--that being the maximum height of a single row. Even if your merged range contains more than one row, the method used by the sub still won't let you go past 409.5 points.

Sub AutoFitMergedCells(Target As Range)
'AutoFits a merged cell range, even though it is technically impossible
Dim MergedWidth As Double, NewHeight As Double, ReqdHeight As Double
Dim cel As Range, celTemp As Range, col As Range, colCopy As Range, rg As Range, rw As Range
Dim Mergers As New Collection
Dim i As Long, nMerge As Long, nRow As Long
Set rg = Target.Cells(1, 1)

If Not rg.MergeCells Then Exit Sub
Application.ScreenUpdating = False

'Identify all the merged ranges in this row
nRow = rg.Row
With Target.Parent      'The worksheet containing the range Target
    For i = 1 To 256
        If .Cells(nRow, i).MergeCells And .Cells(nRow, i).WrapText Then
            nMerge = nMerge + 1
            Mergers.Add Item:=.Cells(nRow, i).MergeArea
            i = i + .Cells(nRow, i).MergeArea.Columns.Count - 1
        End If
    Next
    Set colCopy = .Columns(256) '.Insert    'Insert an empty column
    Set celTemp = colCopy.Cells(nRow, 1)
End With

For i = 1 To nMerge   'Loop through all the merged areas on this row
    Set rg = Mergers(i)
    With rg
            MergedWidth = 0
            Set cel = .Cells(1, 1)
            For Each col In .Columns
                MergedWidth = col.Width + MergedWidth           'Measured in points
            Next col
           
            .MergeCells = False
            colCopy.ColumnWidth = 0.1905 * MergedWidth - 0.7139     'Convert from points to "characters"
            cel.Copy
            celTemp.PasteSpecial xlPasteValues
            celTemp.PasteSpecial xlPasteFormats
            .MergeCells = True
           
            celTemp.EntireRow.AutoFit
             
            'For some reason, celTemp.EntireRow.Height changes when .MergeCells=True
            If celTemp.EntireRow.Height > ReqdHeight Then ReqdHeight = celTemp.EntireRow.Height
    End With
Next
colCopy.ClearContents
i = Target.Parent.UsedRange.Rows.Count
Target.RowHeight = Application.Max(ReqdHeight / Target.Rows.Count + 0.49, 12.75)    'Round row height up to 0.5 points, minimum of 12.75 points
If ReqdHeight >= 409.5 Then MsgBox "Warning! Text is truncated because maximum merged cell height is 409.5 points"
Application.ScreenUpdating = True
End Sub

Brad

 

[thomgreen]

Thanks for the Response! Is this code correct. I am having issues with it. It compiles fine but it does not show up on the list when I try and assign the macro.

If I take out the 'Target As Range' I am able to recognize the macro but of course it does not run without error.

Should it be something like (ByVal Target As Range)? Sorry but I am not very experienced in complex macros.

 

[byundt]

thomgreen,
I assumed that you would call my previous sub with your own code. Something like this would AutoFit all the cells in a selection:

Sub AutoFitCurrentColumn()
Dim cel As Range
For Each cel In Intersect(Selection, ActiveSheet.UsedRange)
    AutoFitMergedCells cel
Next
End Sub

Brad