Macro inside of Macro

[john.clancy]

2 part question, 1st part:
How do I change this macro from looking at 1 highlighted merge cell to
run, to running the whole worksheet merge cells.

Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range, RangeWidth As Single
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
RangeWidth = .Width
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth +
MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
While .Cells(1).Width < RangeWidth
.Cells(1).ColumnWidth = .Cells(1).ColumnWidth + 0.5
Wend
.Cells(1).ColumnWidth = .Cells(1).ColumnWidth - 0.5
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub

2nd part:
How do I put the above macro into the macro below:

Print and Save Macro

Dim Msg, Style, Title, Help, Ctxt, Response, MyString
'
' Save Current Spreadsheet

Sheets("CTL Report").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True

' commented out below Save since will be read-only copy
' ActiveWorkbook.Save

'Check if user has entered correct report date

DateEntry = Range("Date_Entry").Value
DateofRpt = Format(DateEntry, "MM-DD-YY")
ShiftEntry = Range("Shift_Entry").Value

Msg = "Do you want to release " & DateofRpt & " " & ShiftEntry & "?"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = "Please Verify Date and Shift"
Help = "DEMO.HLP"
Ctxt = 1000
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then

' Strip current of formulas

Sheets("CTL Report").Select
' Unprotect Sheet
ActiveSheet.Unprotect
Cells.Select
Range("b3").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Range("b3").Select
Application.CutCopyMode = False


' Save current As another sheet in archives - PLUG IN NORCO
DIRECTORY STRUCTURE
' You'll be keeping the master copy in a directory like
S:\lab_shift_turnover
' And you'll have an Archives folder under that, and a folder for the
year under that
' This release function will save a copy of the report into the
archives
' With the date and shift as a part of the report name

' For other reports, substitute area for Lite Oil

ChDir "\\Americas.shell.com\Americas\Chemicals\SCC
Norco\Department\Prod\ESP\Shift Reports"
DateEntry = Range("Date_Entry").Value
DateofRpt = Format(DateEntry, "MM-DD-YY")
ShiftEntry = Range("Shift_Entry").Value
FiletoSave = "file:\\Americas.shell.com\Americas\Chemicals\SCC
Norco\Department\Prod\ESP\Shift Reports\ " & DateofRpt & " " &
ShiftEntry
ActiveWorkbook.SaveAs Filename:=FiletoSave, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=True, CreateBackup:=False
Sheets("CTL Report").Select
Cells.Select
Range("b3").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Sheets("CTL Report").Select
ActiveSheet.PrintOut , Copies:=1
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True
Range("B3").Select

ActiveWorkbook.Save

End If
'
End Sub

 

[Guest]

The second part is easy: I am not sure at what point you want the
AutoFitMergedCell Row Height to run but at whatever point you want it to run
make sure the ActiveSheet is set correctly and just put a line that says:
AutoFitMergedCellRowHeight()
The () is optional

The first part seems tricky to me. There does not seem to be any built-in
collection that points to any merged cells. The MergeCells property will let
you check a range for them but to check an entire sheet? And to deal with
multiple areas? And the fact that they can span several rows/columns? All
that makes it tough and time-consuming to look for them. I have been trying
to find an easy way but no luck so far - perhaps someone else will know of
one. It has my brain working but I need to get back to other work...

 

[Tom Ogilvy]

Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range, RangeWidth As Single
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim rng As Range, cell As Range, ar as Range
For Each cell In ActiveSheet.UsedRange
If cell.Address <> cell.MergeArea.Address Then
If rng Is Nothing Then
Set rng = cell.MergeArea
Else
If Intersect(cell, rng) Is Nothing Then
Set rng = Union(rng, cell.MergeArea)
End If
End If
End If
Next
if not rng is nothing then
for each ar in rng.Areas
ar.Select
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
RangeWidth = .Width
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + _
MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
While .Cells(1).Width < RangeWidth
.Cells(1).ColumnWidth = .Cells(1).ColumnWidth + 0.5
Wend
.Cells(1).ColumnWidth = .Cells(1).ColumnWidth - 0.5
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
Next ar
End Sub

----------------------------

Print and Save Macro

Dim Msg, Style, Title, Help, Ctxt, Response, MyString
'
' Save Current Spreadsheet

Sheets("CTL Report").Select

AutoFitMergedCellRowHeight


ActiveSheet.Protect DrawingObjects:=True, _
Contents:=True,Scenarios:=True

.. . .