Excel VBA code to trace precedents of cell - vba

Question

I have the following code which traces the precedents of an active cell and spits out a message box with the info. (It also searches for precedents in other worksheets and workbooks).
I am new to VBA, and I would like to request help on changing this code to spit out the precedent cell, formula, and address into a new worksheet after the active worksheet. Please can someone help me understand how to do this.
Should I create a new function to create a new sheet and copy the dynamic info onto it within the first sub?
For example, if I have the formula A1 + B1 in cell C1 of Sheet1, then I want a row in Sheet2 (newly created sheet) which shows Target Cell as C1, Target Sheet as Sheet1, Source Cell as A1, and Source Sheet as Sheet1. I also want another row in Sheet2 which shows Target Cell as C1, Target Sheet as Sheet1, Source Cell as B1, and Source Sheet as Sheet1.
Sheet2:
Code:
Option Explicit
Public OtherWbRefs As Collection
Public ClosedWbRefs As Collection
Public SameWbOtherSheetRefs As Collection
Public SameWbSameSheetRefs As Collection
Public CountOfClosedWb As Long
Dim headerString As String
Sub RunMe()
Call FindCellPrecedents(ActiveCell)
End Sub
Sub FindCellPrecedents(homeCell As Range)
Dim i As Long, j As Long, pointer As Long
Dim maxReferences As Long
Dim outStr As String
Dim userInput As Long
If homeCell.HasFormula Then
Set OtherWbRefs = New Collection: CountOfClosedWb = 0
Set SameWbOtherSheetRefs = New Collection
Set SameWbSameSheetRefs = New Collection
Rem find closed precedents from formula String
Call FindClosedWbReferences(homeCell)
Rem find Open precedents from navigate arrows
homeCell.Parent.ClearArrows
homeCell.ShowPrecedents
headerString = "in re: the formula in " & homeCell.Address(, , , True)
maxReferences = Int(Len(homeCell.Formula) / 3) + 1
On Error GoTo LoopOut:
For j = 1 To maxReferences
homeCell.NavigateArrow True, 1, j
If ActiveCell.Address(, , , True) = homeCell.Address(, , , True) Then
Rem closedRef
Call CategorizeReference("<ClosedBook>", homeCell)
Else
Call CategorizeReference(ActiveCell, homeCell)
End If
Next j
LoopOut:
On Error GoTo 0
For j = 2 To maxReferences
homeCell.NavigateArrow True, j, 1
If ActiveCell.Address(, , , True) = homeCell.Address(, , , True) Then Exit For
Call CategorizeReference(ActiveCell, homeCell)
Next j
homeCell.Parent.ClearArrows
Rem integrate ClosedWbRefs (from parsing) With OtherWbRefs (from navigation)
If ClosedWbRefs.Count <> CountOfClosedWb Then
If ClosedWbRefs.Count = 0 Then
MsgBox homeCell.Address(, , , True) & " contains a formula with no precedents."
Exit Sub
Else
MsgBox "string-" & ClosedWbRefs.Count & ":nav " & CountOfClosedWb
MsgBox "Methods find different # of closed precedents."
End
End If
End If
pointer = 1
For j = 1 To OtherWbRefs.Count
If OtherWbRefs(j) Like "<*" Then
OtherWbRefs.Add Item:=ClosedWbRefs(pointer), key:="closed" & CStr(pointer), after:=j
pointer = pointer + 1
OtherWbRefs.Remove j
End If
Next j
Rem present findings
outStr = homeCell.Address(, , , True) & " contains a formula with:"
outStr = outStr & vbCrLf & vbCrLf & CountOfClosedWb & " precedents in closed workbooks."
outStr = outStr & vbCr & (OtherWbRefs.Count - CountOfClosedWb) & " precedents in other workbooks that are open."
outStr = outStr & vbCr & SameWbOtherSheetRefs.Count & " precedents on other sheets in the same workbook."
outStr = outStr & vbCr & SameWbSameSheetRefs.Count & " precedents on the same sheet."
outStr = outStr & vbCrLf & vbCrLf & "YES - See details about Other Books."
outStr = outStr & vbCr & "NO - See details about The Active Book."
Do
userInput = MsgBox(prompt:=outStr, Title:=headerString, Buttons:=vbYesNoCancel + vbDefaultButton3)
Select Case userInput
Case Is = vbYes
MsgBox prompt:=OtherWbDetail(), Title:=headerString, Buttons:=vbOKOnly
Case Is = vbNo
MsgBox prompt:=SameWbDetail(), Title:=headerString, Buttons:=vbOKOnly
End Select
Loop Until userInput = vbCancel
Else
MsgBox homeCell.Address(, , , True) & vbCr & " does not contain a formula."
End If
End Sub
Sub CategorizeReference(Reference As Variant, Home As Range)
Rem assigns reference To the appropriate collection
If TypeName(Reference) = "String" Then
Rem String indicates reference To closed Wb
OtherWbRefs.Add Item:=Reference, key:=CStr(OtherWbRefs.Count)
CountOfClosedWb = CountOfClosedWb + 1
Else
If Home.Address(, , , True) = Reference.Address(, , , True) Then Exit Sub
If Home.Parent.Parent.Name = Reference.Parent.Parent.Name Then
Rem reference In same Wb
If Home.Parent.Name = Reference.Parent.Name Then
Rem sameWb sameSheet
SameWbSameSheetRefs.Add Item:=Reference.Address(, , , True), key:=CStr(SameWbSameSheetRefs.Count)
Else
Rem sameWb Other sheet
SameWbOtherSheetRefs.Add Item:=Reference.Address(, , , True), key:=CStr(SameWbOtherSheetRefs.Count)
End If
Else
Rem reference To other Open Wb
OtherWbRefs.Add Item:=Reference.Address(, , , True), key:=CStr(OtherWbRefs.Count)
End If
End If
End Sub
Sub FindClosedWbReferences(inRange As Range)
Rem fills the collection With closed precedents parsed from the formula String
Dim testString As String, returnStr As String, remnantStr As String
testString = inRange.Formula
Set ClosedWbRefs = New Collection
Do
returnStr = NextClosedWbRefStr(testString, remnantStr)
ClosedWbRefs.Add Item:=returnStr, key:=CStr(ClosedWbRefs.Count)
testString = remnantStr
Loop Until returnStr = vbNullString
ClosedWbRefs.Remove ClosedWbRefs.Count
End Sub
Function NextClosedWbRefStr(FormulaString As String, Optional ByRef Remnant As String) As String
Dim workStr As String
Dim start As Long, interval As Long, del As Long
For start = 1 To Len(FormulaString)
For interval = 2 To Len(FormulaString) - start + 1
workStr = Mid(FormulaString, start, interval)
If workStr Like Chr(39) & "[!!]*'![$A-Z]*#" Then
If workStr Like Chr(39) & "[!!]*'!*[$1-9A-Z]#" Then
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "#")
interval = interval - 3 * CLng(Mid(FormulaString, start + interval, 1) = ":")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
NextClosedWbRefStr = Mid(FormulaString, start, interval)
Remnant = Mid(FormulaString, start + interval)
Exit Function
End If
End If
Next interval
Next start
End Function
Function OtherWbDetail() As String
Rem display routine
OtherWbDetail = OtherWbDetail & "There are " & OtherWbRefs.Count & " references to other workbooks. "
OtherWbDetail = OtherWbDetail & IIf(CBool(CountOfClosedWb), CountOfClosedWb & " are closed.", vbNullString)
OtherWbDetail = OtherWbDetail & vbCr & "They appear in the formula in this order:" & vbCrLf & vbCrLf
OtherWbDetail = OtherWbDetail & rrayStr(OtherWbRefs, vbCr)
End Function
Function SameWbDetail() As String
Rem display routine
SameWbDetail = SameWbDetail & "There are " & SameWbOtherSheetRefs.Count & " ref.s to other sheets in the same book."
SameWbDetail = SameWbDetail & vbCr & "They appear in this order, including duplications:" & vbCrLf & vbCrLf
SameWbDetail = SameWbDetail & rrayStr(SameWbOtherSheetRefs, vbCr)
SameWbDetail = SameWbDetail & vbCrLf & vbCrLf & "There are " & SameWbSameSheetRefs.Count & " precedents on the same sheet."
SameWbDetail = SameWbDetail & vbCr & "They are (out of order, duplicates not noted):" & vbCrLf & vbCrLf
SameWbDetail = SameWbDetail & rrayStr(SameWbSameSheetRefs, vbCr)
End Function
Function rrayStr(ByVal inputRRay As Variant, Optional Delimiter As String)
Rem display routine
Dim xVal As Variant
If IsEmpty(inputRRay) Then Exit Function
If Delimiter = vbNullString Then Delimiter = " "
For Each xVal In inputRRay
rrayStr = rrayStr & Delimiter & xVal
Next xVal
rrayStr = Mid(rrayStr, Len(Delimiter) + 1)
End Function

Answer 1

I believe it is best to add two new functions:
add the "info sheet" (and store it in a variable for later use)
Sub addInfoSheet()
Dim oldSheet
Set oldSheet = ActiveSheet
Sheets.Add After:=ActiveSheet
Set infoSheet = Sheets(ActiveSheet.Index)
oldSheet.Select
End Sub
a sub that stores one line to the sheet, something like:
Sub addRowToInfoSheet(targetSheet As String, targetRange As String, sourceSheet As String, sourceRange As String)
infoSheet.Cells(rowInInfoSheet, 1) = targetSheet
infoSheet.Cells(rowInInfoSheet, 2) = targetRange
infoSheet.Cells(rowInInfoSheet, 3) = sourceSheet
infoSheet.Cells(rowInInfoSheet, 4) = sourceRange
rowInInfoSheet = rowInInfoSheet + 1
End Sub
Let me know if this helps.

Answer 2

EDIT: (v0.2) Now works for all sheets in current workbook. (And fleshed out for other workbooks.)
You could do something sneaky and hook the MsgBox function and parse the data from its output.
Just do a global search for MsgBox in your code and replace it with, for example, MsgBoxInterceptor.
Then you write the MsgBoxInterceptor() function, oh, say like the one below ;)
Run the RunMe() sub like normal, and voila! Instead of output to the screen, you get output to a new worksheet.
No need to even work out what your original code is doing!
NB The function provided only pulls the precedents from the active workbook.
'v0.2
Private Function MsgBoxInterceptor _
( _
Prompt, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title, _
Optional HelpFile, _
Optional Context _
) _
As VBA.VbMsgBoxResult
Const i_TargetCell As Long = 1
Const i_TargetSheet As Long = 2
Const i_SourceCell As Long = 3
Const i_SourceSheet As Long = 4
Static slngState As Long
Static srngDataRow As Range
Static sstrTargetCell As String
Static sstrTargetSheet As String
Static slngClosedBookCount As Long
Static slngOpenBookCount As Long
Static slngSameBookCount As Long
Static slngSameSheetCount As Long
Dim f As WorksheetFunction: Set f = WorksheetFunction
Dim lngBegin As Long
Dim lngEnd As Long
Dim i As Long
Select Case slngState
Case 0: ' Get counts and target
Worksheets.Add After:=ActiveSheet
Set srngDataRow = ActiveSheet.Range("A1:D1")
srngDataRow.Value = Split("Target Cell:Target Sheet:Source Cell:Source Sheet", ":")
Set srngDataRow = srngDataRow.Offset(1)
lngBegin = InStr(1, Prompt, "]") + 1
lngEnd = InStr(lngBegin, Prompt, "'")
sstrTargetSheet = Mid$(Prompt, lngBegin, lngEnd - lngBegin)
srngDataRow.Cells(i_TargetSheet) = sstrTargetSheet
lngBegin = InStr(lngEnd, Prompt, "$") + 1
lngEnd = InStr(lngBegin, Prompt, " ")
sstrTargetCell = f.Substitute(Mid$(Prompt, lngBegin, lngEnd - lngBegin), "$", "")
srngDataRow.Cells(i_TargetCell) = sstrTargetCell
lngBegin = InStr(lngEnd, Prompt, ":") + 3
lngEnd = InStr(lngBegin, Prompt, " ")
slngClosedBookCount = Val(Mid$(Prompt, lngBegin, lngEnd - lngBegin))
lngBegin = InStr(lngEnd, Prompt, ".") + 2
lngEnd = InStr(lngBegin, Prompt, " ")
slngOpenBookCount = Val(Mid$(Prompt, lngBegin, lngEnd - lngBegin))
lngBegin = InStr(lngEnd, Prompt, ".") + 2
lngEnd = InStr(lngBegin, Prompt, " ")
slngSameBookCount = Val(Mid$(Prompt, lngBegin, lngEnd - lngBegin))
lngBegin = InStr(lngEnd, Prompt, ".") + 2
lngEnd = InStr(lngBegin, Prompt, " ")
slngSameSheetCount = Val(Mid$(Prompt, lngBegin, lngEnd - lngBegin))
slngState = slngState + 1
MsgBoxInterceptor = vbNo
Case 1: ' Get same book sources
lngEnd = InStr(1, Prompt, "[")
For i = 1 To slngSameBookCount
srngDataRow.Cells(i_TargetCell) = sstrTargetCell
srngDataRow.Cells(i_TargetSheet) = sstrTargetSheet
lngBegin = InStr(lngEnd, Prompt, "]") + 1
lngEnd = InStr(lngBegin, Prompt, "'")
srngDataRow.Cells(i_SourceSheet) = Mid$(Prompt, lngBegin, lngEnd - lngBegin)
lngBegin = InStr(lngEnd, Prompt, "$") + 1
lngEnd = InStr(lngBegin, Prompt, Chr$(13))
srngDataRow.Cells(i_SourceCell) = f.Substitute(Mid$(Prompt, lngBegin, lngEnd - lngBegin), "$", "")
Set srngDataRow = srngDataRow.Offset(1)
Next i
For i = 1 To slngSameSheetCount
srngDataRow.Cells(i_TargetCell) = sstrTargetCell
srngDataRow.Cells(i_TargetSheet) = sstrTargetSheet
lngBegin = InStr(lngEnd, Prompt, "]") + 1
lngEnd = InStr(lngBegin, Prompt, "'")
srngDataRow.Cells(i_SourceSheet) = Mid$(Prompt, lngBegin, lngEnd - lngBegin)
lngBegin = InStr(lngEnd, Prompt, "$") + 1
lngEnd = InStr(lngBegin, Prompt, Chr$(13))
If lngEnd = 0 Then lngEnd = Len(Prompt) + 1
srngDataRow.Cells(i_SourceCell) = f.Substitute(Mid$(Prompt, lngBegin, lngEnd - lngBegin), "$", "")
Set srngDataRow = srngDataRow.Offset(1)
Next i
slngState = slngState + 1
MsgBoxInterceptor = vbOK
Case 2: ' Just skipping through
slngState = slngState + 1
MsgBoxInterceptor = vbYes
Case 3: 'Get other book sources (STILL TODO)
lngEnd = InStr(1, Prompt, "")
For i = 1 To slngClosedBookCount
srngDataRow.Cells(i_TargetCell) = sstrTargetCell
srngDataRow.Cells(i_TargetSheet) = sstrTargetSheet
' lngBegin = InStr(lngEnd, Prompt, "]") + 1
' lngEnd = InStr(lngBegin, Prompt, "'")
' srngDataRow.Cells(i_SourceSheet) = Mid$(Prompt, lngBegin, lngEnd - lngBegin)
'
' lngBegin = InStr(lngEnd, Prompt, "$") + 1
' lngEnd = InStr(lngBegin, Prompt, Chr$(13))
' srngDataRow.Cells(i_SourceCell) = f.Substitute(Mid$(Prompt, lngBegin, lngEnd - lngBegin), "$", "")
Set srngDataRow = srngDataRow.Offset(1)
Next i
For i = 1 To slngOpenBookCount
srngDataRow.Cells(i_TargetCell) = sstrTargetCell
srngDataRow.Cells(i_TargetSheet) = sstrTargetSheet
' lngBegin = InStr(lngEnd, Prompt, "]") + 1
' lngEnd = InStr(lngBegin, Prompt, "'")
' srngDataRow.Cells(i_SourceSheet) = Mid$(Prompt, lngBegin, lngEnd - lngBegin)
'
' lngBegin = InStr(lngEnd, Prompt, "$") + 1
' lngEnd = InStr(lngBegin, Prompt, Chr$(13))
' If lngEnd = 0 Then lngEnd = Len(Prompt) + 1
' srngDataRow.Cells(i_SourceCell) = f.Substitute(Mid$(Prompt, lngBegin, lngEnd - lngBegin), "$", "")
Set srngDataRow = srngDataRow.Offset(1)
Next i
slngState = slngState + 1
MsgBoxInterceptor = vbOK
Case 4: ' Finished -> tidy up
srngDataRow.EntireColumn.AutoFit
slngState = 0
MsgBoxInterceptor = vbCancel
Case Else
End Select
End Function
Explanation:
The key to this code is the use of static variables, created with the Static keyword. These retain their values even after VBA stops running and is restarted. They are used in the code to allow a state machine to be constructed, which mimics a set sequence of user interaction with the message boxes.
The rest is just string parsing of the MsgBox messages.

Answer 3

EDIT: (v0.2) Now displays error messages.
EDIT: (v0.3) Now does a full trace back to hard-coded values.
All fun aside, if you're serious about tracing all the way back to a hard-coded value, the best way is to write a main RunMe_Controller sub to control the original code. Together with a hook function (and some helper function), this is actually the simplest way to leverage the existing code.
The MsgBoxInterceptor() function is smart enough to allow error messages through but silently traps all other MsgBox() calls.
See the section at the bottom of the answer for further important details.
Installation:
Copy/paste the new bug-fixed RunMe code block to a module;
Insert v0.3 of the following updated code block into the previous code where indicated;
Do a "Current Module", "Find Whole Words Only" search for MsgBox with replacement MsgBoxInterceptor;
Add the following two references to the VBA project.
Microsoft VBScript Regular Expressions 5.5
Microsoft Scripting Runtime
Code:
'===============================================================================
' Module : <in any standard module>
' Version : 0.3
' Part : 1 of 1
' References : Microsoft VBScript Regular Expressions 5.5
' : Microsoft Scripting Runtime
' Online : https://stackoverflow.com/a/46036068/1961728
'===============================================================================
Private Const l_No_transformation As String = "No transformation"
Private Enum i_
z__NONE = 0
SourceCell
SourceSheet
SourceBook
TargetCell
TargetSheet
TargetBook
Formula
Index
SourceRef
z__NEXT
z__FIRST = z__NONE + 1
z__LAST = z__NEXT - 1
End Enum
Private meMsgBoxResult As VBA.VbMsgBoxResult
'v0.3
Public Sub RunMe_Controller()
Const s_Headers As String = "Source Cell::Source Sheet::Source Book::Target Cell::Target Sheet::Target Book::Formula"
Const s_Separator As String = "::"
Const l_Circular As String = "Circular"
Dim ƒ As Excel.WorksheetFunction: Set ƒ = Excel.WorksheetFunction
Dim dictFullRefTrace As Scripting.Dictionary '##Early Bound## As Object
Dim varRootRef As Variant
Dim varTargetRef As Variant
Dim varSavedTraceStepKey As Variant
Dim varNewTraceStep As Variant
Dim strNewKey As String
Application.ScreenUpdating = False 'Set to true for psychedelic display
Set dictFullRefTrace = New Dictionary '##Early Bound## = CreateObject("Scripting.Dictionary")
varRootRef = ActiveCell.Address(External:=True)
dictFullRefTrace.Add varRootRef & s_Separator & s_Separator, TheRefTraceStepAsArray(varRootRef)
dictFullRefTrace.Add s_Separator & s_Separator, TheRefTraceStepAsArray() 'Need two trace steps in dict to start dynamic expansion
For Each varSavedTraceStepKey In dictFullRefTrace: Do ' Can't use .Items as it is not dynamically expanded
If varSavedTraceStepKey = s_Separator & s_Separator Then ' Dummy trace step (dict exhausted) -> clean up fake trace steps
dictFullRefTrace.Remove varRootRef & s_Separator & s_Separator
dictFullRefTrace.Remove s_Separator & s_Separator
Exit Do
End If
varTargetRef = dictFullRefTrace(varSavedTraceStepKey)(i_.SourceRef)
Select Case True
Case varTargetRef Like "'?:*": ' Closed Wb -> ignore for now (TODO - auto open it)
Exit Do
Case varSavedTraceStepKey Like "*#": ' "No transformation" (from its own trace step) -> ignore
Exit Do
Case varSavedTraceStepKey Like "*" & l_Circular: ' "Circular" (from its own trace step) -> ignore
Exit Do
End Select
meMsgBoxResult = vbOK
FindCellPrecedents Evaluate(varTargetRef) ' ~= RunMe() - leverage the existing code to update the global Ref Collections
Select Case meMsgBoxResult
Case vbOK:
For Each varNewTraceStep In TheNewTraceSteps(fromTarget:=varTargetRef).Items
strNewKey = varNewTraceStep(i_.SourceRef) & s_Separator & varTargetRef & s_Separator
If dictFullRefTrace.Exists(strNewKey) Then ' Target is a circular ref -> mark it and then add it
strNewKey = strNewKey & l_Circular
varNewTraceStep(i_.Formula) = l_Circular
End If
If Not dictFullRefTrace.Exists(strNewKey) Then ' Ignore subsequent circular refs for this target
dictFullRefTrace.Add strNewKey, varNewTraceStep
End If
Next varNewTraceStep
Case vbIgnore: ' No transformation - typically occurs multiple times, so need multiple unique keys
varNewTraceStep = TheRefTraceStepAsArray(varTargetRef, varTargetRef)
strNewKey = varTargetRef & s_Separator & varTargetRef & s_Separator & varNewTraceStep(i_.Index)
dictFullRefTrace.Add strNewKey, varNewTraceStep
Case vbAbort: ' Error occurred and message was displayed
Exit Sub
Case Else
' Never
End Select
' Move dummy trace step to end
dictFullRefTrace.Remove s_Separator & s_Separator
dictFullRefTrace.Add s_Separator & s_Separator, vbNullString
Loop While 0: Next varSavedTraceStepKey
' Create, fill and format worksheet
With Evaluate(varRootRef)
.Worksheet.Parent.Activate
Worksheets.Add after:=.Worksheet
End With
With ActiveSheet.Rows(1).Resize(ColumnSize:=i_.Index - i_.z__FIRST + 1)
.Value2 = Split(s_Headers, s_Separator)
.Font.Bold = True
With .Offset(1).Resize(RowSize:=dictFullRefTrace.Count)
.Cells.Value = ƒ.Transpose(ƒ.Transpose(dictFullRefTrace.Items)) ' Fill
.Sort .Columns(i_.Index), xlDescending, Header:=xlNo
End With
With .EntireColumn
.Columns(i_.Formula).Copy
.Columns(i_.Index).PasteSpecial Paste:=xlPasteValues
.Columns(i_.Formula).Delete
.Columns(i_.SourceCell).HorizontalAlignment = xlCenter
.Columns(i_.TargetCell).HorizontalAlignment = xlCenter
.AutoFilter i_.Formula, l_Circular
.Columns(i_.Formula).SpecialCells(xlCellTypeConstants).Font.Color = vbRed
.AutoFilter i_.Formula, l_No_transformation
.Columns(i_.Formula).SpecialCells(xlCellTypeConstants).Font.Bold = True
.AutoFilter
.Rows(1).Font.ColorIndex = xlAutomatic
.AutoFit
End With
.Cells(1).Select
End With
Application.ScreenUpdating = True
End Sub
Private Function TheNewTraceSteps _
( _
Optional ByRef fromTarget As Variant _
) _
As Scripting.Dictionary '##Early Bound## As Object
Dim pvarTargetRef As Variant: pvarTargetRef = fromTarget
Dim mtchMultiCellAddress As VBScript_RegExp_55.Match '##Early Bound## As Object
Dim strFormula As String
Dim rngCell As Range
Dim strKey As String
Dim astrTraceStep() As String
Dim varRunMeSourceRef As Variant
Dim varRefCollection As Variant
Set TheNewTraceSteps = New Dictionary '##Early Bound## = CreateObject("Scripting.Dictionary")
strFormula = Evaluate(pvarTargetRef).Formula
With New VBScript_RegExp_55.RegExp '##Early Bound## = CreateObject("VBScript_RegExp_55.RegExp")
.Global = True
.Pattern = "(?:(?:[:]| *)(?:\$?[A-Z]{1,3}\d+:\$?[A-Z]{1,3}\d+))+"
If .test(strFormula) Then
For Each mtchMultiCellAddress In .Execute(strFormula)
For Each rngCell In Evaluate(mtchMultiCellAddress.Value)
strKey = rngCell.Address
If Not TheNewTraceSteps.Exists(strKey) Then
astrTraceStep = TheRefTraceStepAsArray(rngCell.Address(External:=True), pvarTargetRef)
TheNewTraceSteps.Add strKey, astrTraceStep
End If
Next rngCell
Next mtchMultiCellAddress
End If
End With
For Each varRefCollection In Array(SameWbSameSheetRefs, SameWbOtherSheetRefs, OtherWbRefs)
For Each varRunMeSourceRef In varRefCollection
strKey = Evaluate(varRunMeSourceRef).Address
If Not TheNewTraceSteps.Exists(strKey) Then
astrTraceStep = TheRefTraceStepAsArray(varRunMeSourceRef, pvarTargetRef)
TheNewTraceSteps.Add strKey, astrTraceStep
End If
varRefCollection.Remove 1
Next varRunMeSourceRef
Next varRefCollection
End Function
Private Function TheRefTraceStepAsArray _
( _
Optional ByRef SourceRef As Variant = vbNullString, _
Optional ByRef TargetRef As Variant = vbNullString _
) _
As String()
Static slngIndex As Long ' Required for reverse ordering of trace output
Dim pvarSourceRef As String: pvarSourceRef = Replace(SourceRef, "''", "'")
Dim pvarTargetRef As String: pvarTargetRef = Replace(TargetRef, "''", "'")
Dim astrTraceStepValues() As String: ReDim astrTraceStepValues(1 To i_.z__LAST)
Dim strFormula As String: strFormula = vbNullString
Dim astrSourceCellSheetBook() As String
Dim astrTargetCellSheetBook() As String
astrSourceCellSheetBook = Ref2CellSheetBook(pvarSourceRef)
astrTargetCellSheetBook = Ref2CellSheetBook(pvarTargetRef)
If pvarSourceRef = vbNullString _
Or pvarTargetRef = vbNullString _
Then
' slngIndex = 0 ' Dummy or root ref, i.e., new trace started -> intialize static variable
Else
slngIndex = slngIndex + 1
With Evaluate(TargetRef)
strFormula = IIf(.HasFormula And pvarSourceRef <> pvarTargetRef, "'" & Mid$(.Formula, 2), l_No_transformation)
End With
End If
astrTraceStepValues(i_.SourceCell) = astrSourceCellSheetBook(1)
astrTraceStepValues(i_.SourceSheet) = astrSourceCellSheetBook(2)
astrTraceStepValues(i_.SourceBook) = astrSourceCellSheetBook(3)
astrTraceStepValues(i_.TargetCell) = astrTargetCellSheetBook(1)
astrTraceStepValues(i_.TargetSheet) = astrTargetCellSheetBook(2)
astrTraceStepValues(i_.TargetBook) = astrTargetCellSheetBook(3)
astrTraceStepValues(i_.Formula) = strFormula
astrTraceStepValues(i_.Index) = slngIndex
astrTraceStepValues(i_.SourceRef) = SourceRef
TheRefTraceStepAsArray = astrTraceStepValues
End Function
Private Function Ref2CellSheetBook(ByRef Ref As Variant) As String()
Dim × As Long: × = 4
Dim astrCellSheetBook() As String: ReDim astrCellSheetBook(1 To i_.z__LAST)
If IsMissing(Ref) Then GoTo ExitFunction:
× = × - 1: astrCellSheetBook(×) = Mid$(Ref, InStr(Ref, "[") + 1, Abs(InStr(Ref, "]") - InStr(Ref, "[") - 1))
× = × - 1: astrCellSheetBook(×) = Mid$(Ref, InStr(Ref, "]") + 1, Abs(InStr(Ref, "!") - InStr(Ref, "]") - 2))
× = × - 1: astrCellSheetBook(×) = Mid$(Ref, InStr(Ref, "!") + 1)
astrCellSheetBook(×) = Replace(astrCellSheetBook(×), "$", "")
ExitFunction:
Ref2CellSheetBook = astrCellSheetBook
End Function
Private Function MsgBoxInterceptor _
( _
Prompt, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title, _
Optional HelpFile, _
Optional Context _
) _
As VBA.VbMsgBoxResult
If Buttons = vbOKOnly _
Then
If Prompt Like "*does not contain a formula*" _
Or Prompt Like "*contains a formula with no precedents*" _
Then
meMsgBoxResult = vbIgnore
Else
meMsgBoxResult = vbAbort
MsgBox Prompt, Buttons, Title, HelpFile, Context
End If
End If
MsgBoxInterceptor = vbCancel
End Function
Bug-fixed original code:
Option Explicit
Public OtherWbRefs As Collection
Public ClosedWbRefs As Collection
Public SameWbOtherSheetRefs As Collection
Public SameWbSameSheetRefs As Collection
Public CountOfClosedWb As Long
Dim headerString As String
' <-- Insert other code here
Sub RunMe()
Call FindCellPrecedents(ActiveCell)
End Sub
Sub FindCellPrecedents(homeCell As Range)
Dim i As Long, j As Long, pointer As Long
Dim maxReferences As Long
Dim outStr As String
Dim userInput As Long
If homeCell.HasFormula Then
Set OtherWbRefs = New Collection: CountOfClosedWb = 0
Set SameWbOtherSheetRefs = New Collection
Set SameWbSameSheetRefs = New Collection
Rem find closed precedents from formula String
Call FindClosedWbReferences(homeCell)
Rem find Open precedents from navigate arrows
homeCell.Parent.ClearArrows
homeCell.ShowPrecedents
headerString = "in re: the formula in " & homeCell.Address(, , , True)
maxReferences = Int(Len(homeCell.Formula) / 3) + 1
On Error GoTo LoopOut:
For j = 1 To maxReferences
homeCell.NavigateArrow True, 1, j
If ActiveCell.Address(, , , True) = homeCell.Address(, , , True) Then
Rem closedRef
Call CategorizeReference("<ClosedBook>", homeCell)
Else
Call CategorizeReference(ActiveCell, homeCell)
End If
Next j
LoopOut:
On Error GoTo 0
For j = 2 To maxReferences
homeCell.NavigateArrow True, j, 1
If ActiveCell.Address(, , , True) = homeCell.Address(, , , True) Then Exit For
Call CategorizeReference(ActiveCell, homeCell)
Next j
homeCell.Parent.ClearArrows
Rem integrate ClosedWbRefs (from parsing) With OtherWbRefs (from navigation)
If ClosedWbRefs.Count <> CountOfClosedWb Then '#robinCTS#' Should read (ParsedClosedWbRefs <> CountOfNavigatedClosedWbRefs)
If ClosedWbRefs.Count = 0 Then
MsgBoxInterceptor homeCell.Address(, , , True) & " contains a formula with no precedents."
Exit Sub
Else
MsgBoxInterceptor "string-" & ClosedWbRefs.Count & ":nav " & CountOfClosedWb
MsgBoxInterceptor "Methods find different # of closed precedents."
End
End If
End If
pointer = 1
For j = 1 To OtherWbRefs.Count
If OtherWbRefs(j) Like "<*" Then
OtherWbRefs.Add Item:=ClosedWbRefs(pointer), Key:="closed" & CStr(pointer), after:=j
pointer = pointer + 1
OtherWbRefs.Remove j
End If
Next j
Rem present findings
outStr = homeCell.Address(, , , True) & " contains a formula with:"
outStr = outStr & vbCrLf & vbCrLf & CountOfClosedWb & " precedents in closed workbooks."
outStr = outStr & vbCr & (OtherWbRefs.Count - CountOfClosedWb) & " precedents in other workbooks that are open."
outStr = outStr & vbCr & SameWbOtherSheetRefs.Count & " precedents on other sheets in the same workbook."
outStr = outStr & vbCr & SameWbSameSheetRefs.Count & " precedents on the same sheet."
outStr = outStr & vbCrLf & vbCrLf & "YES - See details about Other Books."
outStr = outStr & vbCr & "NO - See details about The Active Book."
Do
userInput = MsgBoxInterceptor(Prompt:=outStr, Title:=headerString, Buttons:=vbYesNoCancel + vbDefaultButton3)
Select Case userInput
Case Is = vbYes
MsgBoxInterceptor Prompt:=OtherWbDetail(), Title:=headerString, Buttons:=vbOKOnly
Case Is = vbNo
MsgBoxInterceptor Prompt:=SameWbDetail(), Title:=headerString, Buttons:=vbOKOnly
End Select
Loop Until userInput = vbCancel
Else
MsgBoxInterceptor homeCell.Address(, , , True) & vbCr & " does not contain a formula."
End If
End Sub
Sub CategorizeReference(Reference As Variant, Home As Range)
Rem assigns reference To the appropriate collection
If TypeName(Reference) = "String" Then
Rem String indicates reference To closed Wb
OtherWbRefs.Add Item:=Reference, Key:=CStr(OtherWbRefs.Count)
CountOfClosedWb = CountOfClosedWb + 1
Else
If Home.Address(, , , True) = Reference.Address(, , , True) Then Exit Sub '#robinCTS#' Never true as same check done in caller
If Home.Parent.Parent.Name = Reference.Parent.Parent.Name Then
Rem reference In same Wb
If Home.Parent.Name = Reference.Parent.Name Then
Rem sameWb sameSheet
SameWbSameSheetRefs.Add Item:=Reference.Address(, , , True), Key:=CStr(SameWbSameSheetRefs.Count)
Else
Rem sameWb Other sheet
SameWbOtherSheetRefs.Add Item:=Reference.Address(, , , True), Key:=CStr(SameWbOtherSheetRefs.Count)
End If
Else
Rem reference To other Open Wb
OtherWbRefs.Add Item:=Reference.Address(, , , True), Key:=CStr(OtherWbRefs.Count)
End If
End If
End Sub
Sub FindClosedWbReferences(inRange As Range) '#robinCTS#' Should read FindParsedOtherWbReferences
Rem fills the collection With closed precedents parsed from the formula String
Dim testString As String, returnStr As String, remnantStr As String
testString = inRange.Formula
Set ClosedWbRefs = New Collection
Do
returnStr = NextClosedWbRefStr(testString, remnantStr)
ClosedWbRefs.Add Item:=returnStr, Key:=CStr(ClosedWbRefs.Count)
testString = remnantStr
Loop Until returnStr = vbNullString '#robinCTS#' Better if add " Or testString = vbNullString"
ClosedWbRefs.Remove ClosedWbRefs.Count '#robinCTS#' then this no longer required
End Sub
Function NextClosedWbRefStr(FormulaString As String, Optional ByRef Remnant As String) As String
Dim workStr As String
Dim start As Long, interval As Long, del As Long
For start = 1 To Len(FormulaString)
For interval = 2 To Len(FormulaString) - start + 1
workStr = Mid(FormulaString, start, interval)
If workStr Like Chr(39) & "[![]*[[]*'![$A-Z]*#" Then '#robinCTS#' Original was "[!!]*'![$A-Z]*#"
If workStr Like Chr(39) & "[![]*[[]*'!*[$1-9A-Z]#" Then '#robinCTS#' Original was "[!!]*'!*[$1-9A-Z]#" Not required?
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "#") '#robinCTS#' Not required as always Like "*#" here?
interval = interval - 3 * CLng(Mid(FormulaString, start + interval, 1) = ":")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
NextClosedWbRefStr = Mid(FormulaString, start, interval)
Remnant = Mid(FormulaString, start + interval)
Exit Function
End If
End If
Next interval
Next start
End Function
Function OtherWbDetail() As String
Rem display routine
OtherWbDetail = OtherWbDetail & "There are " & OtherWbRefs.Count & " references to other workbooks. "
OtherWbDetail = OtherWbDetail & IIf(CBool(CountOfClosedWb), CountOfClosedWb & " are closed.", vbNullString)
OtherWbDetail = OtherWbDetail & vbCr & "They appear in the formula in this order:" & vbCrLf & vbCrLf
OtherWbDetail = OtherWbDetail & rrayStr(OtherWbRefs, vbCr)
End Function
Function SameWbDetail() As String
Rem display routine
SameWbDetail = SameWbDetail & "There are " & SameWbOtherSheetRefs.Count & " ref.s to other sheets in the same book."
SameWbDetail = SameWbDetail & vbCr & "They appear in this order, including duplications:" & vbCrLf & vbCrLf
SameWbDetail = SameWbDetail & rrayStr(SameWbOtherSheetRefs, vbCr)
SameWbDetail = SameWbDetail & vbCrLf & vbCrLf & "There are " & SameWbSameSheetRefs.Count & " precedents on the same sheet."
SameWbDetail = SameWbDetail & vbCr & "They are (out of order, duplicates not noted):" & vbCrLf & vbCrLf
SameWbDetail = SameWbDetail & rrayStr(SameWbSameSheetRefs, vbCr)
End Function
Function rrayStr(ByVal inputRRay As Variant, Optional Delimiter As String)
Rem display routine
Dim xVal As Variant
If IsEmpty(inputRRay) Then Exit Function
If Delimiter = vbNullString Then Delimiter = " "
For Each xVal In inputRRay
rrayStr = rrayStr & Delimiter & xVal
Next xVal
rrayStr = Mid(rrayStr, Len(Delimiter) + 1)
End Function
Issues:
Closed workbooks are not auto-opened (yet)
Formulas referencing closed workbooks will display the pathname
Formulas referencing open workbooks won't display the pathname, unlike your example
Only expands simple hard-coded multi-cell ranges (for now)
Doesn't expand whole columns or rows, yet, only grabs the first cell
Doesn't find/expand INDEX, OFFSET or any other similar calculated ranges
Expanded ranges are not sorted any may not be ordered nicely.
Features/Enhancements:
RunMe code bugfixes now allow proper detection of closed workbook refs as requested
Simple multi-cell ranges now expand out as requested
Circular references are properly accounted for
Hard-coded values show a bold "No transformation" as requested
Hard-coded values display multiple times if accessed from multiple targets
Apostrophes in sheet names are properly taken care of
Note: If you are curious about my variable naming convention, it is based on RVBA.