Info Only: Formula Freeze Module

[Johnny M]

Thought I would post this code for posterity. I developed it with help from
this group.

I use this module in conjuction with a simple user interface. It allows the
user to develop a list of formulas to "freeze". When I say freeze, I mean paste
the value of the formula to the cell. This is helpful for people who need to
email formula-laden worksheets to others who do not have the requisite excel
modules to use the formulas (in this case - Hyperion Retrieve). Email me to
get the complete add-in with UI. Below is the guts of this addin.

This code has been tested to a limited extent. However, the error trapping
is not yet fully developed. As errors arise, I'll add to it.

Public Function RecordAdd(strNewFormula As String) As Boolean
'This procedure expands range name for formula list and adds new record.
'The Range name is FormulaList and it must exist, or an error will occur.
On Error Resume Next
Dim lngRows As Long
Dim rngTest As Range

RecordAdd = False

With Application
.ScreenUpdating = False
End With

'Test to see if forumla already exists in list. If it does, exit.
With Application.Workbooks("Formula Freeze.xla").Sheets("List").Range("FormulaList")
Set rngTest = .Find(strNewFormula)
If Not rngTest Is Nothing Then
Exit Function
End If
End With

'Add new formula to list.
With Application.Workbooks("Formula Freeze.xla").Sheets("List").Range("FormulaList")
lngRows = .Rows.Count + 1
.Cells(lngRows) = Trim(strNewFormula)
.Resize(lngRows).Name = "FormulaList"
RecordAdd = True
End With

With Application
.ScreenUpdating = True
End With

Set rngTest = Nothing
Exit Function
End Function

Public Sub RecordDelete(strFormula As String)
On Error Resume Next
'This procedure contracts range name for formula list and deletes a record.
Dim rngDelete As Range

With Application
.ScreenUpdating = False
End With

Set rngDelete = Application.Workbooks("Formula Freeze.xla").Sheets("List") _
.Range("FormulaList").Find(strFormula, LookIn:=xlValues)
With rngDelete
.Delete xlUp
End With

With Application
.ScreenUpdating = True
End With

Set rngDelete = Nothing
End Sub

Public Sub Freeze(intOption As Integer)
On Error Resume Next
'This procedure does the freezing of formulas based on user parameter.
'Key to parameters:
'1 = Freeze all formulas in all sheets of the workbook.
'2 = Freeze current sheet only.
'3 = Freeze selected cells only.

'Branch to appropriate subroutine.
Select Case intOption
Case 1
FreezeAll
Case 2
FreezeCurrent
Case 3
FreezeSelected
Case Else
Exit Sub
End Select
End Sub

Private Sub FreezeAll()
On Error Resume Next

Dim Wks As Worksheet
Dim cell As Object

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

'Cycle through sheets collection.
With Wks
For Each Wks In ActiveWorkbook.Worksheets
Wks.Activate
For Each cell In ActiveSheet.UsedRange.Cells
'Cycle through all cells in UsedRange.
If cell.HasFormula Then
'Only pass cells with formulas to the freezeme routine.
FreezeMe Range(cell.Address)
End If
Next
Next
End With

With Application
.ScreenUpdating = False
.Calculation = xlCalculationAutomatic
End With

End Sub

Public Sub FreezeCurrent()
On Error Resume Next
Dim cell As Object

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

'Cycle through cells in usedrange in current sheet only.
For Each cell In ActiveSheet.UsedRange.Cells
If cell.HasFormula Then
FreezeMe Range(cell.Address)
End If
Next

With Application
.ScreenUpdating = False
.Calculation = xlCalculationAutomatic
End With

Set cell = Nothing
End Sub

Public Sub FreezeSelected()
On Error Resume Next
Dim cell As Object

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

'Cycle through cells in current selection only.
For Each cell In Selection
If cell.HasFormula Then
FreezeMe Range(cell.Address)
End If
Next

With Application
.ScreenUpdating = False
.Calculation = xlCalculationAutomatic
End With

Set cell = Nothing
End Sub

Private Sub FreezeMe(rngFreeze As Range)
On Error Resume Next
Dim strContents As String
Dim strTest As String
Dim rngTest As Range
Dim rng As Range
Set rng = rngFreeze
'Parse cell and store formula in string variable.
strContents = rng.Formula
'Test contents to see if it is correct formula (e.g. =XXX(YY) and not +1+2+3.
If InitialParse(strContents) Then
'Store only the formula name in the test string.
strTest = Mid(Trim(strContents), 2, CLng(InStr(1, Trim(strContents), "(") - 2))
Else
Exit Sub
End If
'Search formula list for formula
Set rngTest = Application.Workbooks("Formula Freeze.xla").Sheets("List") _
.Range("FormulaList").Find(strTest)
If rngTest Is Nothing Then
Exit Sub
End If

'Formula is in the list, therefore, freeze cell.
With rngFreeze
.Copy
.PasteSpecial xlPasteValues
End With
Set rngTest = Nothing
Set rng = Nothing
End Sub

Private Function InitialParse(strValue As String) As Boolean
'This function tests to see if the character "(" exists in
'the formula. If it does not, InitialParse evaluates to false.
On Error Resume Next
Dim i As Integer
InitialParse = False
For i = 1 To Len(strValue)
If Mid(strValue, i, 1) = "(" Then
InitialParse = True
End If
Next
End Function