Function GetFormula(Cell As Range) As String
'Application.Volatile = True
If VarType(Cell) = 8 And Not Cell.HasFormula Then
GetFormula = "'" & Cell.Formula
Else
GetFormula = Cell.Formula
End If
If Cell.HasArray Then _
GetFormula = "{" & Cell.Formula & "}"
End FunctionFunction Eval(Func As String, ParamA As Variant, ValueA As Variant, Optional ReturnType As Long = 1) As Variant
Dim Eform As String, i As Long
' Evaluate a function (Func), replacing the parameters listed in the
' range "ParamA" with the corresponding values in "ValueA"
'Func is a single cell or text string containing the function to be evaluated
'ParamA and ValueA are single column ranges containing the same number of
'cells
' ReturnType = 0 to return the function with values substituted for variables
' ReturnType = 1 (default) to return evaluated function
ParamA = ParamA.Value2
ValueA = Valuea.Value2
Eform = Func
For i = 1 To UBound(ParamA, 1) - LBound(ParamA, 1) + 1
Eform = Replace(Eform, ParamA(i, 1), ValueA(i, 1))
Next i
If ReturnType = 0 Then
Eval = Eform
Else
Eval = Evaluate(Eform)
End If
End Function
Sub GetRefs()
Dim MyRange As Range, strFormula As String, strVal As String, FormCell As Range
Dim NumRows As Long, FormA() As String, i As Long, Outrange As Range
NumRows = Selection.Rows.Count
ReDim FormA(1 To NumRows, 1 To 1)
i = 1
For Each FormCell In Selection.Areas(1).Cells
With FormCell
strFormula = .Formula
For Each MyRange In .Precedents.Cells
With MyRange
strVal = " " & Range(.Address).Value & " "
strFormula = Replace(strFormula, .Address, strVal)
strFormula = Replace(strFormula, .Address(RowAbsolute:=False), strVal)
strFormula = Replace(strFormula, .Address(ColumnAbsolute:=False), strVal)
strFormula = Replace(strFormula, .Address(RowAbsolute:=False, ColumnAbsolute:=False), strVal)
End With
Next
strVal = "' " & .Formula & "; " & strFormula
End With
FormA(i, 1) = strVal
i = i + 1
Next
With Selection
If .Areas.Count > 1 Then
Set Outrange = .Areas(2)
Else
Set Outrange = Selection.Offset(0, 1)
End If
End With
Outrange.Value = FormA
End Sub