Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Automate External References | Excel Discussion (Misc queries) | |||
Listing of cell references from a FIND All command. | Excel Discussion (Misc queries) | |||
How to check if an excel sheet has external references. | Excel Discussion (Misc queries) | |||
External References | Excel Discussion (Misc queries) | |||
Listing all external links within a file | Excel Programming |