Excel VBA code to track cell use cases

Question

I have the following code that tracks the use cases of the active cell and gives a window with information. (He also seeks precedents in other sheets and books.)

I am new to VBA, and I would like to ask for help about changing this code in order to splash out the cell, formula, and use case address into a new worksheet after the active worksheet. Please help me understand how to do this.

Should I create a new function to create a new sheet and copy dynamic information to it during the first sub?

For example, if I have the formula A1 + B1 in cell C1 Sheet1, then I need a row in Sheet2 (a newly created sheet) that shows Target Cell as C1 , Target Sheet as Sheet1 , Source cell as A1 and Source sheet as Sheet1 . I also need another row in Sheet2 that shows Target Cell as C1 , Target Sheet as Sheet1 , Source Cell as B1 and Source Sheet as Sheet1 .

Sheet2:

the 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) & "[!!]*'![$AZ]*#" 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

EDIT: (v0.2) Now error messages are displayed.

EDIT: (v0.3) Now the full trace returns to hard-coded values.

Take a detour to the side, if you are serious about tracing down to hard-coded values, the best way is to write the main RunMe_Controller sub to control the source code. Together with the hook function (and some helper function), this is actually the easiest way to use existing code.

The MsgBoxInterceptor() function is smart enough to skip error messages, but it silently captures all other calls to MsgBox() .

See the section at the bottom of the answer for more details.

Installation:

• Copy / paste into the module the new corrected RunMe code of the module;
• Insert v0.3 of the following updated code block into the previous code, where indicated:
• Make "Current module", "Search for whole words only", find MsgBox with replacement MsgBoxInterceptor ;
• Add the following two links to the VBA project.
  • Microsoft VBScript 5.5 Regular Expressions
  • Microsoft Scripting Execution

The 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 = "(?:(?:[:]| *)(?:\$?[AZ]{1,3}\d+:\$?[AZ]{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, ie, 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 

---

Fixed source code with an error:

 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) & "[![]*[[]*'![$AZ]*#" Then '#robinCTS#' Original was "[!!]*'![$AZ]*#" 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 

Questions:

• Closed books do not open automatically (yet)
• Formulas that reference closed books will display the path
• Formulas that refer to open books will not display the path name, unlike your example
• Extends only simple ranges with multiple cells (currently)
• Does not expand whole columns or rows, but only captures the first cell
• Does not find / extend INDEX , OFFSET or any other similar calculated ranges
• Extended ranges are not sorted, any may not be ordered nicely.

Features / Improvements:

• RunMe Fixed code errors that now allow you to correctly define closed links to a workbook upon request
• Simple multi-cell ranges now expand upon request
• Circular links are properly accounted for.
• Hard-coded values ​​show live "No conversion" on request
• Hard-coded values ​​are displayed multiple times if accessed from multiple targets
• Apostrophes in sheet names are properly followed

Note. If you are curious about my variable naming convention, it is based on RVBA .

Answer 2

I find it better to add two new features:

• add the "information sheet" (and save 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 

• sub, which stores one line per sheet, for example:

   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 3

EDIT: (v0.2) Now works for all sheets in the current workbook. (And was created for other books.)

---

You can do something hidden and connect the MsgBox function and analyze the data from its output.

Just do a global search of MsgBox in your code and replace it with, for example, MsgBoxInterceptor .

Then you write the function MsgBoxInterceptor() , oh, say, as shown below;)

Run RunMe() sub as normal, and voila! Instead of displaying on the screen, you get output on a new worksheet.

No need to even figure out what your original code does!

NB. The above function only draws use cases from the active book.

 '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:

, Static . , VBA . , , .

- MsgBox .