Using a recursive NavigateArrows Method to analyse all local and off sheet cell dependencies

Public Const strSourceSht = "Trial Balance"
Public Const strKeySht = "BS Movement"

Sub Main()
    Dim ws As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim i As Long
    Set ws = ThisWorkbook.Sheets(strSourceSht)
    Set rng1 = ws.Range(ws.[a2], ws.Cells(Rows.Count, "A").End(xlUp))
    If rng1 Is Nothing Then Exit Sub
    rng1.EntireColumn.Interior.ColorIndex = xlNone
    Application.ScreenUpdating = False
    For Each rng2 In rng1
        If Len(rng2.Value) > 0 Then
            rng2.NumberFormat = "@"
            If CellUsedinFormula(Trim(rng2.Value)) Then
            Else
                i = i + 1
                rng2.Interior.Color = vbRed
            End If
        End If
    Next
    For Each ws In ActiveWorkbook.Worksheets
        ws.ClearArrows
    Next ws
    Application.Goto rng1.Cells(1)
    Application.ScreenUpdating = True
    If i > 0 Then MsgBox i & " cells were found that are not used" & vbNewLine & "these have been coloured red"
End Sub

Function CellUsedinFormula(strFormula As String) As Boolean
    Dim ws As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim strTest As String
    Dim strFirst As String
    Dim bFound As Boolean

    'Look in each worksheet for the strings in the list from "Trial Balance"
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> strSourceSht Then
            On Error Resume Next
            Set rng1 = ws.Cells.SpecialCells(xlCellTypeFormulas)
            On Error GoTo 0
            'Look in formula cells only
            If Not rng1 Is Nothing Then
                'the string searches and later string comparisons are case insenstive
                'so that the code can be easily modified to look for text rather than numeric strings
                Set rng2 = rng1.Find(strFormula, , xlFormulas, xlPart, xlByRows, , False)
                'For a case senstive search make the last argument TRUE, ie
                'Set rng2 = rng1.Find(strFormula, , xlFormulas, xlPart, xlByRows, , TRUE)

                'If the string is found, used a regular expression UDF to test for an exact match
                If Not rng2 Is Nothing Then
                    strTest = LCase$(strFormula)
                    bFound = ExactMatch(strTest, rng2)
                    If bFound Then Exit For
                    strFirst = rng2.Address
                    Do
                        Set rng2 = rng1.FindNext(rng2)
                        bFound = ExactMatch(strTest, rng2)
                        'If a valid reference is found then stop the search for the string
                        If bFound Then Exit For
                    Loop While Not rng2 Is Nothing And rng2.Address <> strFirst
                    Exit For
                End If
            End If
        End If
    Next
    CellUsedinFormula = bFound
End Function
Function ExactMatch(ByVal strTest, ByVal rng2) As Boolean
    Dim regex As Object
    Dim regM As Object
    Dim RegC As Object
    Dim bDependentRange As Boolean
    Set regex = CreateObject("vbscript.regexp")
    regex.Pattern = "\d+"
    regex.Global = True
    Set regM = regex.Execute(rng2.Formula)
    For Each RegC In regM
        If StrComp(LCase$(strTest), RegC, vbBinaryCompare) = 0 Then
            If rng2.Parent.Name = strKeySht Then
                ExactMatch = True
            Else
                'Call the recursive dependents function to test if this string
                'is eventually referred to on P&L Forecast
                bDependentRange = oneCellsDependents(rng2)
                If bDependentRange Then
                    'exit on a successful match
                    ExactMatch = True
                    Exit Function
                End If
            End If
        End If
    Next
End Function

Function oneCellsDependents(ByVal rng2) As Boolean
'initial code credited to Bill Manville
'brettdj adapted this code from a post by mike rickson
    Dim strAddress As String
    Dim rngReturn As Range
    Dim i As Long
    Dim lPreCount As Long
    Dim bFndTarget As Boolean

    'set the point to return to
    Set rngReturn = Selection
    strAddress = rng2.Parent.Name & "!" & rng2.Address

    ' use the NavigateArrow method to follow cell dependencies
    With rng2
        .ShowDependents
        .NavigateArrow dodependents, 1
        'recursive loop through dependents
        Do Until ActiveCell.Parent.Name & "!" & ActiveCell.Address = strAddress
            lPreCount = lPreCount + 1
            .NavigateArrow dodependents, lPreCount
            If ActiveCell.Parent.Name = strKeySht Then
                oneCellsDependents = True
                Exit Do
            Else
                'recursive function call below
                bFndTarget = oneCellsDependents(ActiveCell)
                'successful search. Leave function
                If bFndTarget = True Then
                    oneCellsDependents = True
                    GoTo LeaveMe
                End If
            End If
            'next dependent
            .NavigateArrow dodependents, lPreCount + 1
        Loop
        If oneCellsDependents Then GoTo LeaveMe
        'remove the auditing arrows
        ActiveCell.ShowDependents Remove:=True
    End With
    'Return selection to where it was
    With rngReturn
        .Parent.Activate
        .Select
    End With
LeaveMe:
End Function

                                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146: