Auto fit wrapped and merged cells in entire worksheet

[danbridgland]

Hi,

I'm using SQL Server Reporting Services to produce reports, i'm then
exporting the reports to excel, only I've run into a known problem
with excel, Merged cells and wraped text dont mix together very well
in excel - the row height is not preserved.

Ive found a fix posted in this group posted by Jim Rech in 2002
(http://groups.google.com/group/microsoft.public.excel.programming/
browse_thread/thread/a5cbe0ee8e6c2a10/93c6bca447bd8902?
#93c6bca447bd8902) in the form of a macro, the macro adjusts row
height for a selected cell so that its contents fits. however, this
macro is designed to work only on a single selected cell.

being a complete excell macro/vba noob, I'm hoping someone out there
can help me fix this macro so that it scans every cell/merged cell in
a worksheet and adjusts the row height to fit its contents.

Here is the macro created by Jim Rech

''Simulates row height autofit for a merged cell if the active cell..
'' is merged.
'' has Wrap Text set.
'' includes only 1 row.
''Unlike real autosizing the macro only increases row height
'' (if needed). It does not reduce row height because another
'' merged cell on the same row may needed a greater height
'' than the active cell.
Sub AutoFitMergedCellRowHeight()
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


Thanks in advance for any assistance.

Regards
Dan

 

[Joel]

If you have more than one merged cell in a column what do you want to do?

 

[danbridgland]

Hi Joel,

I'm not exactly sure I follow your question, but I'll take a stab at
answering it anyway.

I do not expect to have any cells merged between rows.
I do expect there to be a number of columns which will have merged
cells.
I do expect to have merged and single cells in any given column.

I hope this helps to answer your question and thanks for your
assistance,

Regards
Dan

 

[danbridgland]

Hi Joel, Maybe I should try to explain what or how I expect the macro
to function.

I'd like the macro to look for word wrapped and merged cells in a
worksheet, once it finds a cell with both criteria, id like it to
increase the height of the row to fit the selected cells contents and
progress to the next cell, continuing until it cant find any more word
wrapped and merged cells in the row, then repeat its search on the
next row.

Thanks again for your assistance.

Regards
Dan

 

[Joel]

I should of said two sets of merged columns in the same row. A macro
searching all the cells for merged cells will adjust for one colun and then
re-adjust for the 2nd column in the same row which will un-adjust the 1st
column.

 

[danbridgland]

Hi Joel,

I only need the maco to increase the row height, This would avoid the
problem you mention.

Regards
Dan

 

[Joel]

Try these changes

Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single

Set LastCell = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
Set UsedRange = Range(Range("A1"), LastCell)
Application.ScreenUpdating = False

For Each Cell In UsedRange
If Cell.mergedarea = True Then
With Cell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then

CurrentRowHeight = .RowHeight
ActiveCellWidth = Cell.ColumnWidth
MergedCellRgWidth = 0
For Each CurrCell In Cell.MergeArea
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
Next Cell

Application.ScreenUpdating = True
End Sub

 

[danbridgland]

Hi Joel,

Thanks again for your continued help.

I've tried the revised code, but I now receive an error.

Run-time error '438':

Object doesn't support this property or method


I pressed debug and it directed me to the 'If Cell.mergedarea = True
Then' line, I changed this to 'If Cell.MergeArea = True Then' but
also fails, with a different message:

Run-time error '13':

Type mismatch


any clue as to where its failing?

Regards
Dan

 

[Joel]

from
Cell.Mergedarea = True
to
Cell.MergeCells = True