Sub doit()
' Test routine
Dim rng As Range, strr As String
Set rng = Selection
If MsgBox("Check Current Cell for Precedents?", vbOK) = vbOK Then
strr = oneCellsDependents(rng, True)
MsgBox strr
End If
If MsgBox("Check Current Cell for Dependents?", vbOK) = vbOK Then
strr = oneCellsDependents(rng, False)
MsgBox strr
End If
End Sub
Function oneCellsDependents(ByVal inRange As Range, Optional doPrecedents As Boolean) As String
Dim inAddress As String, returnSelection As Range, NavRng As Range, WSname As Variant, WSnameStr As String
Dim i As Long, pCount As Long, pTot As Long, qCount As Long, qCountTot As Long, AddrStr As String
Dim WB As Workbook, OpenFlg As Boolean
Set returnSelection = inRange
inAddress = fullAddress(inRange, True)
Application.ScreenUpdating = False
On Error Resume Next
pTot = 0
' the number of precedents/dependents is the number on the current worksheet
' plus one if there are any on another worksheet or workbook
If (doPrecedents) Then
pTot = inRange.DirectPrecedents.Count
Else
pTot = inRange.DirectDependents.Count
End If
If pTot = 0 Then
oneCellsDependents = IIf(doPrecedents, "Cell has no Precedents", "Cell has no Dependents")
Exit Function
End If
On Error GoTo 0
With inRange
.ShowPrecedents
.ShowDependents
pCount = 1
qCount = 1
qCountTot = 0 ' counts the number of dependents/precedents found
Do
On Error Resume Next
Set NavRng = .NavigateArrow(doPrecedents, pCount, qCount)
If (Err.Number <> 0) Then ' you don't know how many external references there are
' so just keep trying until you ge an error
pCount = pCount + 1 ' move on
qCount = 1
Err.Clear
Set NavRng = .NavigateArrow(doPrecedents, pCount, qCount)
End If
On Error GoTo 0 ' go back to generating errors
If (fullAddress(NavRng, True) = inAddress) Then ' if the destination workbook is not open
' there is no error but it returns the cell you are starting from
' if you find one give the user the option of trying to open it
' get a list of all the other workbooks and check each of them against the formula
' if you find a match you open the workbook and go back again to check the precedent
' if you choose not to open the workbook it is counted but not listed
If (MsgBox("Formula contains reference to external Workbook that is not open" & vbCrLf _
& "Do you wish to attempt to open the Workbook", vbYesNo) = vbYes) Then
For Each WSname In ActiveWorkbook.LinkSources(xlExcelLinks)
WSnameStr = "[" & Mid(WSname, InStrRev(WSname, "\") + 1, 999) & "]"
If (InStr(1, returnSelection.Formula, WSnameStr, vbTextCompare) > 0) Then
OpenFlg = True
For Each WB In Workbooks
If "[" & WB.Name & "]" = WSnameStr Then
OpenFlg = False
End If
Next
If (OpenFlg) Then
Workbooks.Open WSname
Exit For
End If
End If
Next
qCountTot = qCountTot - 1
Else
qCount = qCount + 1
End If
ElseIf ((NavRng.Parent.Name <> inRange.Parent.Name) Or _
(NavRng.Parent.Parent.Name <> inRange.Parent.Parent.Name)) Then
' check if both the worksheet name and workbook name match
' if not it is an external reference so include workbook name and worksheet name
qCount = qCount + 1
oneCellsDependents = oneCellsDependents & fullAddress(NavRng, True) & Chr(13)
Else ' reference is local so only report the address
oneCellsDependents = oneCellsDependents & fullAddress(NavRng, False) & Chr(13)
pCount = pCount + 1
qCount = 1
End If
qCountTot = qCountTot + 1
Loop While (pCount <= pTot)
oneCellsDependents = fullAddress(inRange, False) & " on worksheet " & inRange.Parent.Name & "has " & qCountTot & _
IIf(doPrecedents, " precedent " & IIf(qCountTot = 1, "range.", "range(s)."), " dependent " & _
IIf(qCountTot = 1, "range.", "range(s).")) & vbCrLf & vbCrLf & oneCellsDependents
.Parent.ClearArrows
End With
Rem return selection to where it was
With returnSelection
.Parent.Activate
.Select
End With
End Function
Function fullAddress(inRange As Range, ExtMode As Boolean) As String
With inRange
fullAddress = .Address(external:=ExtMode)
End With
End Function
