Option Explicit
Public CollectionHoldsValues As Boolean
Public subValCollection As New Collection
Function SubVal(inputRange As Range) As String
Application.Volatile
On Error GoTo OutOfFtn
If CollectionHoldsValues Then
On Error Resume Next
SubVal = subValCollection(inputRange.Range("A1").Address(, , , True))
On Error GoTo 0
Else
On Error Resume Next
subValCollection.Add Item:=inputRange.Range("a1"), key:=inputRange.Range("a1").Address(, , , True)
On Error GoTo 0
SubVal = "null"
End If
Exit Function
OutOfFtn:
SubVal = vbNullString
On Error GoTo 0
End Function
Function ValuesInsteadOfPrecedents(ByVal inRange As Range) As String
Rem returns the formula of inRange With value replacing references
Dim PrecedentsRRay As Variant
Dim onePrecedent As Variant
Dim formulaString As String
If inRange.Cells.Count = 1 Then
ValuesInsteadOfPrecedents = inRange.Formula
PrecedentsRRay = ArrayOfPrecedents(inRange)
If UBound(PrecedentsRRay) = 0 Then Exit Function
If PrecedentsRRay(1) Is Nothing Then Exit Function
For Each onePrecedent In PrecedentsRRay
ValuesInsteadOfPrecedents = SwapValueForRange(ValuesInsteadOfPrecedents, onePrecedent)
Next onePrecedent
End If
End Function
Function SwapValueForRange(formulaStr As String, replaceRange As Variant) As String
Rem replace one precedent With its value In the formula String
Const Indicator As String = "\"
Dim testStr As String
Dim replacementString As String
If replaceRange.Cells.Count = 1 Then
replacementString = Indicator & CStr(replaceRange.Text)
Else
replacementString = Indicator & CStr(replaceRange.Range("A1").Text) & ":" & Indicator
With replaceRange
replacementString = replacementString & CStr(.Cells(.Rows.Count, .Columns.Count).Text)
End With
End If
formulaStr = Application.Substitute(formulaStr, "$", vbNullString)
SwapValueForRange = formulaStr
SwapValueForRange = Application.Substitute(SwapValueForRange, replaceRange.Address(False, False, xlA1, True), replacementString)
If SwapValueForRange = formulaStr Then
testStr = replaceRange.Address(False, False, xlA1, True)
testStr = Left(testStr, InStr(testStr, "[") - 1) & Mid(testStr, InStr(testStr, "]") + 1)
SwapValueForRange = Application.Substitute(SwapValueForRange, testStr, replacementString)
If SwapValueForRange = formulaStr Then
SwapValueForRange = Application.Substitute(SwapValueForRange, replaceRange.Address(False, False), replacementString)
End If
End If
End Function
Function ArrayOfPrecedents(homeCell As Range) As Variant
Rem returns an array of all of the homeCell 's precedent
Dim startPlace As Range, startWindow As Window
Dim outRRay() As Range
Dim i As Long, pointer As Long
Set startPlace = Selection
Set startWindow = ActiveWindow
If homeCell.HasFormula Then
ReDim outRRay(1 To Len(homeCell.Formula))
On Error Resume Next
homeCell.Parent.ClearArrows
Application.EnableSound = False
homeCell.ShowPrecedents: Rem problem Line
Application.EnableSound = True
On Error GoTo 0
On Error GoTo FoundAllExternalPrecedents
For i = 1 To UBound(outRRay)
homeCell.NavigateArrow True, 1, i
If Selection.Address(, , , True) = homeCell.Address(, , , True) Then
Rem closedRef
Else
pointer = pointer + 1
Set outRRay(pointer) = Selection
End If
Next i
FoundAllExternalPrecedents:
On Error GoTo 0
For i = 2 To UBound(outRRay)
homeCell.NavigateArrow True, i, 1
If Selection.Address(, , , True) = homeCell.Address(, , , True) Then Exit For
pointer = pointer + 1
Set outRRay(pointer) = Selection
Next i
On Error Resume Next
homeCell.Parent.ClearArrows
On Error GoTo 0
ReDim Preserve outRRay(1 To Application.Max(1, pointer))
ArrayOfPrecedents = outRRay
Else
ReDim outRRay(0 To 0)
ArrayOfPrecedents = outRRay
End If
startWindow.Activate
Application.Goto reference:=startPlace, Scroll:=False
End Function
