Option Explicit
Public arrPrecedents() As Variant
Public intCurrent As Integer
Sub storeprecedents()
Call subFindPrecedents
End Sub
Sub displayprecedents()
If intCurrent = UBound(arrPrecedents) Then
intCurrent = 1
Else
intCurrent = intCurrent + 1
End If
Selection.Cells(1).Select
Worksheets(Range(arrPrecedents(intCurrent)).Parent.Name).Activate
Range(arrPrecedents(intCurrent)).Select
If Range(arrPrecedents(intCurrent)).Cells(1).Row <> 1 Then
ActiveWindow.ScrollRow = Range(arrPrecedents(intCurrent)).Cells(1).Row - 1
End If
If Range(arrPrecedents(intCurrent)).Cells(1).Column <> 1 Then
ActiveWindow.ScrollColumn = Range(arrPrecedents(intCurrent)).Cells(1).Column - 1
End If
End Sub
Public Sub subFindPrecedents()
Dim rngSelected As Range
Dim i As Integer
ActiveWorkbook.Save
Set rngSelected = fncSelectCell
If rngSelected Is Nothing Then
Exit Sub
End If
If Not rngSelected.HasFormula Then
Exit Sub
End If
Worksheets(rngSelected.Parent.Name).Activate
Erase arrPrecedents
arrPrecedents = fncCellPrecedents(rngSelected)
intCurrent = LBound(arrPrecedents)
Worksheets(rngSelected.Parent.Name).Activate
End Sub
Public Function fncCellPrecedents(rngCell As Range) As Variant()
Dim colResultRanges As New Collection
Dim varResultRangeArray() As Variant
Dim strFormula As String
Dim strElements() As String
Dim count As Integer
Dim i As Integer
If rngCell.Cells.count <> 1 Or rngCell.HasFormula = False Then
Exit Function
End If
strFormula = Mid(rngCell.Formula, 2, Len(rngCell.Formula) - 1)
If fncIsRange(strFormula) Then
colResultRanges.Add Range(strFormula), 1
Else
strFormula = Replace(strFormula, "(", " ")
strFormula = Replace(strFormula, ")", " ")
strElements() = fncSplitMultiDelims(strFormula, " +-*/\^")
For i = LBound(strElements) To UBound(strElements)
If fncIsRange(Trim(strElements(i))) Then
If rngCell.Parent.Name = Range(strElements(i)).Parent.Name Then
strElements(i) = rngCell.Parent.Name & "!" & strElements(i)
End If
colResultRanges.Add Trim(strElements(i))
count = count + 1
End If
Next
End If
ReDim varResultRangeArray(1 To colResultRanges.count)
For i = 1 To colResultRanges.count
varResultRangeArray(i) = CStr(colResultRanges(i))
Next
fncCellPrecedents = varResultRangeArray
End Function
Public Function fncIsRange(var As Variant) As Boolean
Dim rng As Range
On Error Resume Next
Set rng = Range(var)
If Err.Number = 0 Then
fncIsRange = True
End If
On Error GoTo 0
End Function
Private Function fncSplitMultiDelims(ByRef Text As String, ByRef DelimChars As String, _
Optional ByVal IgnoreConsecutiveDelimiters As Boolean = False, _
Optional ByVal Limit As Long = -1) As String()
Dim ElemStart As Long, N As Long, M As Long, Elements As Long
Dim lDelims As Long, lText As Long
Dim arr() As String
lText = Len(Text)
lDelims = Len(DelimChars)
If lDelims = 0 Or lText = 0 Or Limit = 1 Then
ReDim arr(0 To 0)
arr(0) = Text
fncSplitMultiDelims = arr
Exit Function
End If
ReDim arr(0 To IIf(Limit = -1, lText - 1, Limit))
Elements = 0: ElemStart = 1
For N = 1 To lText
If InStr(DelimChars, Mid(Text, N, 1)) Then
arr(Elements) = Mid(Text, ElemStart, N - ElemStart)
If IgnoreConsecutiveDelimiters Then
If Len(arr(Elements)) > 0 Then Elements = Elements + 1
Else
Elements = Elements + 1
End If
ElemStart = N + 1
If Elements + 1 = Limit Then Exit For
End If
Next N
If ElemStart <= lText Then arr(Elements) = Mid(Text, ElemStart)
If IgnoreConsecutiveDelimiters Then If Len(arr(Elements)) = 0 Then Elements = Elements - 1
ReDim Preserve arr(0 To Elements)
fncSplitMultiDelims = arr
End Function
Private Function fncSelectCell() As Range
Dim rngSelected As Range
Do While True
On Error Resume Next
Set rngSelected = Application.InputBox( _
Title:="Range selection", _
Prompt:="Select a single cell containing a formula.", _
Type:=8)
On Error GoTo 0
If rngSelected Is Nothing Then
Exit Do
End If
If rngSelected.CountLarge = 1 And rngSelected.HasFormula Then
Set fncSelectCell = rngSelected
Exit Do
End If
Loop
End Function