This will list all of the precedent cells of the Active Cell, including named ranges (returned as addresses).
Two string arrays are created:
InternalPrecedentAddresses and ExternalPrecedentAddresses
(Non-Mac users can use Join instead of the UDF rrayStr)
Sub test()
Dim internalPrecColl As New Collection, internalPrecedentAddresses() As String
Dim externalPrecColl As New Collection, externalPrecedentAddresses() As String
Dim i As Long, j As Long, xVal As Variant
Dim homeCell As Range, currentSelection As Range
Dim precCell As Range
Set homeCell = ActiveCell
Set currentSelection = Selection
homeCell.Parent.ClearArrows
homeCell.ShowPrecedents
i = 0: j = 0
Do
j = j + 1
i = 0
Do
i = i + 1
On Error Resume Next
homeCell.NavigateArrow True, j, i
Set precCell = ActiveCell
If precCell.Parent.Parent.Name = homeCell.Parent.Parent.Name Then
internalPrecColl.Add Item:=precCell, key:=precCell.Address(, , , True)
Else
externalPrecColl.Add Item:=precCell, key:=precCell.Address(, , , True)
End If
On Error GoTo 0
Loop Until precCell.Address(, , , True) = homeCell.Address(, , , True)
Loop Until i = 1
internalPrecColl.Remove homeCell.Address(, , , True)
homeCell.Parent.ClearArrows
currentSelection.Parent.Activate
currentSelection.Select
Rem collections to arrays
If CBool(internalPrecColl.Count) Then
ReDim internalPrecedentAddresses(1 To internalPrecColl.Count)
For i = 1 To internalPrecColl.Count
xVal = internalPrecColl(i).Address(, , , True)
internalPrecedentAddresses(i) = Mid(xVal, InStr(xVal, "]") + 1)
Next i
End If
If CBool(externalPrecColl.Count) Then
ReDim externalPrecedentAddresses(1 To externalPrecColl.Count)
For i = 1 To externalPrecColl.Count
externalPrecedentAddresses(i) = externalPrecColl(i).Address(, , , True)
Next i
End If
Rem display results
If CBool(internalPrecColl.Count) Then
MsgBox "Internal Precedents:" & vbCr & rrayStr(internalPrecedentAddresses, vbCr)
Else
MsgBox "No internal precedents"
End If
If CBool(externalPrecColl.Count) Then
MsgBox "External Precedents:" & vbCr & rrayStr(externalPrecedentAddresses, vbCr)
Else
MsgBox "No external precedents"
End If
End Sub
Function rrayStr(ByVal inputRRay As Variant, Optional Delimiter As String)
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