Listing External Worksheet references to your sheet
 

I am auditing workbooks with multiple references to external sheets
and wanted to create a list of the ranges which are being referenced,
without repeating the many duplicates which occur. The following
code, adapted from Bill Manville and Paul S from a thread dated Aug
14-5, 2001 creates a list of the unique external references.

Option Base 1
Public extPrec()
Sub runSheet()
Dim refColl As New Collection

For Each t In ActiveSheet.UsedRange
If InStr(t.Formula, "!") 0 Then
t.Activate
FindPrecedents
On Error Resume Next
Err.Number = 0
For Each r In extPrec
refColl.Add r, CStr(r)

Next
On Error GoTo 0

End If
Next

If refColl.Count 0 Then
nbrofRefs = refColl.Count

ReDim myReflist(nbrofRefs, 1)
For s = 1 To nbrofRefs
myReflist(s, 1) = refColl(s)
Next

refsheetname = ActiveSheet.Name & "refs"
Worksheets.Add befo=Sheets(1)
ActiveSheet.Name = refsheetname
Range("a1:a" & nbrofRefs) = myReflist
End If
End Sub


Sub FindPrecedents()
' this procedure finds the cells which are the direct precedents of
the
'active cell
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim STMSG As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
Erase extPrec

ActiveCell.ShowPrecedents
Set rLast = ActiveCell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=True,
ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) =
ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
If rLast.Worksheet.Parent.Name =
ActiveCell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name = ActiveCell.Parent.Name Then
' local
' STMSG = STMSG & vbNewLine & Selection.Address
Else
' external
a = a + 1
ReDim Preserve extPrec(1, a)
If InStr(Selection.Parent.Name, " ") 0 Then
extShtName = "'" & Selection.Parent.Name & "'"
Else
extShtName = Selection.Parent.Name
End If
extPrec(1, a) = extShtName & "!" & Selection.Address
End If
Else
' external
a = a + 1
ReDim Preserve extPrec(1, a)
extPrec(1, a) = "'" & Selection.Address(external:=True)
End If
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
Exit Sub
End Sub