Macro in 1 cell vs entire spreadsheet

[Darin Kramer]

Hi guys,

I have a macro (see Below) that works when you run it, BUT ONLY runs on
the currently selected cell.
I need it to run over the entire spreadsheet (or preferably over a range
that I specify, say A5:s100 - there are several sheets and ranges
though...)

Please can someone help....

Kind Regards

Darin


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

 

[Tom Ogilvy]

You can try this untested modification and see if it helps.

Sub AutoFitMergedCellRowHeight()
Dim cell as Range, rng as Range
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
for each cell in Selection
if rng is nothing then
set rng = cell.MergeArea
else
if Intersect(rng,cell.MergeArea) is nothing then
if cell.MergeCells then
set rng = union(rng,cell.MergeArea)
end if
end if
end if
if rng is nothing then exit sub
for each cell in rng.Areas
cell.select
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
Next
End Sub

 

[Darin Kramer]

Thanks Tom,

I get a "For control variable already in use" error and it highlights
the following VBA

For Each cell In rng.Areas
(16 lines down)

This is the final Macro in the book I been preparing, so really
desparate for it to work. Thanks so much for the effort.

 

[Tom Ogilvy]

left out the End for
for the NEXT

Sub AutoFitMergedCellRowHeight()
Dim cell As Range, rng As Range
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
For Each cell In Selection
If rng Is Nothing Then
Set rng = cell.MergeArea
Else
If Intersect(rng, cell.MergeArea) Is Nothing Then
If cell.MergeCells Then
Set rng = Union(rng, cell.MergeArea)
End If
End If
End If
Next
If rng Is Nothing Then Exit Sub
For Each cell In rng.Areas
cell.Select
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
Next
End Sub

 

[Darin Kramer]

Thanks Tom,
I sorta guessed to put that next in. I dont get an error message, but
the formulae seems to work erraticly... ie does not work on a block of
text, but will work on certain types of info, eg blank line above merged
text, resolves spacing with merged text fine. Two blank lines, or more
than one line of merged text... no go..

Really appreciate your assistance - this is the big one!! - calling it a
night, but will check first thing tomorrow.
Thanks a million!

 

[Tom Ogilvy]

does the original code work on those cells which you say are problematic?
(the orginal code run on each of the merged areas individually)

 

[Darin Kramer]

Morning Tom,

TO answer your question, yes the original code does work on each of the
cells individually.

When selecting multiple occurences, your code works on the first
occurence, but not on the remaining. (takes the cursor to the last
occurence, but does not resize.

If i select all occurences, and run the original code, it does not work
at all.

Thanks so much, hoping we can resolve...

Big Thanks

D

 

[Tom Ogilvy]

MergeCells, Merge, Autofit, Rech

Try this:

Sub AutoFitMergedCellRowHeight()
' modification of code originally posted by Jim Rech
Dim cell As Range, rng As Range
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
For Each cell In Selection
If cell.MergeCells Then
If rng Is Nothing Then
Set rng = cell.MergeArea(1)
Else
If Intersect(rng, cell.MergeArea(1)) Is Nothing Then
If cell.MergeCells Then
Set rng = Union(rng, cell.MergeArea(1))
End If
End If
End If
End If
Next
If rng Is Nothing Then Exit Sub
For Each cell In rng
cell.Select
If cell.MergeCells Then
With cell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
MergedCellRgWidth = 0
ActiveCellWidth = cell.ColumnWidth
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
End Sub