Excel VBA code to trace precedents of cell

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

that's why I said 'I have the following code' =p haha trying not to reinvent the wheel — Kaitlyn
And that's why I put "No need to even work out what your original code is doing!" in my answer. Seemed much easier (and way more fun) to just grab the pre-formatted data from the MsgBox :) — robinCTS

JensS JensS · Accepted Answer · 2017-09-03T17:28:38

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.

Excel VBA code to trace precedents of cell

3 Answers