Option Explicit
Public arrPrecedents() As Variant
Public intCurrent As Integer
Sub storeprecedents()
'
' storeprecedents Macro
'
' Keyboard Shortcut: Ctrl+q
'
' Select cell with formula.
' Place this line of code in your own macro.
Call subFindPrecedents
End Sub
Sub displayprecedents()
'
' displayprecedents Macro
'
' Keyboard Shortcut: Ctrl+w
'
' Display Precedents.
' Place these lines of code in your own macro.
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
' https://stackoverflow.com/questions/11320626/does-excel-have-a-built-in-method-for-parsing-formulas-ie-to-obtain-a-list-of
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
' **********************************************************************************************
' fncSplitMultiDelims by Alain Bryden
' https://www.experts-exchange.com/articles/1480/How-to-Split-a-String-with-Multiple-Delimiters-in-VBA.html
' **********************************************************************************************
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
