Community Pick: Many members of our community have endorsed this article.

Excel code to find and report on links in the selected ActiveWorkbook (formulas, range names, pivotTables & charts)

Dave
CERTIFIED EXPERT
Published:
A little background as to how I came to I design this code:

Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs, formulas etc. One of the key addin features was the ability to colour code cells that contained links to other workbooks, this functionality proved very popular, especially for people in the finance area who quite often need to work with convoluted inter-linked files for monthly and quarterly reporting.

While linked Excel workbook designs are flexible, powerful and offer simple updating capability, such designs are also fragile. Anyone who has worked with a linked Excel workbook structure for a decent amount of time will have experienced at least one major OMG moment that required major rework.

Over the last two years I spent much of my time designing a corporate valuation process to measure the value of over 200 different assets. The summary file set that underpinned this process ended up totaling 32 files, the size of this file set was driven by the need to provide templates to different business segments. These summary files were in turn linked to numerous different files inside these businesses.

At this stage I realised that both my addin and Bill Manville's must-have addin FindLink ( http://www.bmsltd.co.uk/MVP/Default.htm ) were flagging 'false' links if "xls" was entered as a portion of text in any cell. As I had insisted on people documenting the basis of their source files this issue became frustrating for auditing the models.  A second minor issue was that links to open - but unsaved - workbooks were not being recognised.

So I modified my code to validate any linked results against VBA's collection of linked files, and to check for links to open unsaved workbooks.

The code below is run as a normal macro:

1) It interrogates the current selected workbook
2) If any links are found, a CSV file with header filters is produced that report on link location, type, linked file path and link value. If no links are
found the code exits

A screenshot of a sample CSV report output is shown below.

To use the code:

1) Press the Alt & F11 keys together to open the Visual Basic Editor (VBE)
2) From the Menu, choose Insert-Module.
3) Paste the code into the right-hand code window.
4) Press the Alt & F11 keys together to close the VBE
5) In xl2003 Go to Tools & Macro & Macros and double-click ListLinks

Please send any comments, feedback or queries to the email address in my EE profile.

Regards

Dave
 
Option Explicit
                       
                      ' This code searches all sheets (worksheets and chart sheets) in the ActiveWorkbook for links
                      ' and compiles a filtered CSV file to report on any:
                      ' #1 Formula links (and validates them against linksources)
                      ' #2 Range Name links
                      ' #3 PivotTable links
                      ' #4a Chart Series links (in both Chart Sheets and Charts on regular Worksheets)
                      ' #4b Chart Title links (in both Chart Sheets and Charts on regular Worksheets)
                       
                      ' Download Bill Manville's FindLink at http://www.bmsltd.co.uk/MVP/Default.htm
                      ' for a tool to manage (ie delete) links
                       
                      ' Notes
                      ' 1) The Chart title method relies on activating the Chart.
                      '         ---> Protected sheets are skipped
                      '         ---> This method does not work in xl2007
                      ' 2) I have deliberately left out error handling as I want to resolve any issues
                       
                      Sub ListLinks()
                          Dim objFSO As Object, objFSOfile As Object
                          Dim wb As Workbook, sh
                          Dim rng1 As Range, rng2 As Range, rng3 As Range, rArea As Range
                          Dim chr As ChartObject, chr1 As Chart
                          Dim lSource, PivCh, chrSrs
                          Dim FSOFileHeader As String, tmpStr As String, chrTitle As String, FirstAddress As String, ReportFile As String, ShProt As String
                          Dim nameCnt As Long
                          Dim FndRngLink As Boolean, FndChrLink As Boolean, FndNameLink As Boolean, FndPivLink As Boolean
                       
                          Application.ScreenUpdating = False
                          'location of report file
                          ReportFile = "c:\LinkReport.csv"
                          FSOFileHeader = "Type,Object Level,Location,Linked Workbook,Full Linked File Path,Reference"
                       
                          Set objFSO = CreateObject("scripting.filesystemobject")
                          On Error Resume Next
                          'if report file is open then ask user to close it
                          Set objFSOfile = objFSO.createtextfile(ReportFile)
                          If Err.Number <> 0 Then
                              MsgBox "Pls close " & vbNewLine & ReportFile & vbNewLine & "then re-run code"
                              Exit Sub
                          End If
                          On Error GoTo 0
                       
                          'write report file headers
                          With objFSOfile
                              .writeline ActiveWorkbook.Path & "," & ActiveWorkbook.Name
                              .writeline FSOFileHeader
                          End With
                       
                          For Each sh In ActiveWorkbook.Sheets
                       
                              Select Case sh.Type
                              Case xlWorksheet
                                  'look at formula cells in each worksheet
                                  Set rng1 = Nothing
                                  Set rng2 = Nothing
                                  Set rng3 = Nothing
                       
                                  On Error Resume Next
                                  Set rng1 = sh.Cells.SpecialCells(xlCellTypeFormulas)
                                  On Error GoTo 0
                                  Application.StatusBar = "Searching formulas in sheet " & sh.Name
                                  If Not rng1 Is Nothing Then
                                      'look for *.xls
                                      With rng1
                                          Set rng2 = .Find("*.xls", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
                                          If Not rng2 Is Nothing Then
                                              FirstAddress = rng2.Address
                                              'validate that the *.xls is part of a linksource
                                              For Each lSource In ActiveWorkbook.LinkSources
                                                  'look in open and closed workbooks
                                                  If InStr(Replace(rng2.Formula, "[", vbNullString), lSource) > 0 Or InStr(rng2.Formula, Right$(rng2.Formula, Len(lSource) - InStrRev(lSource, "\"))) > 0 Then
                                                      FndRngLink = True
                                                      'write to the report file
                                                      Set rng3 = rng2
                                                      Exit For
                                                  End If
                                              Next
                                              'repeat till code loops back to first formula cell containing "*.xls"
                                              Do
                                                  Set rng2 = .FindNext(rng2)
                                                  If rng2.Address <> FirstAddress Then
                                                      For Each lSource In ActiveWorkbook.LinkSources
                                                          If InStr(Replace(rng2.Formula, "[", vbNullString), lSource) > 0 Or InStr(rng2.Formula, Right$(lSource, Len(lSource) - InStrRev(lSource, "\"))) > 0 Then
                                                              Set rng3 = Union(rng3, rng2)
                                                              Exit For
                                                          End If
                                                      Next
                                                  End If
                                              Loop Until rng2.Address = FirstAddress
                                          End If
                                      End With
                                  End If
                       
                                  If Not rng3 Is Nothing Then
                                      For Each rArea In rng3.Areas
                                          objFSOfile.writeline "Formula," & "Range" & "," & sh.Name & "!" & Replace(rArea.Address(0, 0), ",", ";") & "," & Right$(lSource, Len(lSource) - InStrRev(lSource, "\")) & "," & lSource & ",'" & rng3.Cells(1).Formula
                                      Next
                                  End If
                       
                                  ' Charts
                                  For Each chr In sh.ChartObjects
                                      Application.StatusBar = "Searching charts in sheet " & sh.Name
                                      For Each chrSrs In chr.Chart.SeriesCollection
                                          If InStr(chrSrs.Formula, ".xls") <> 0 Then
                                              For Each lSource In ActiveWorkbook.LinkSources
                                                  'look in open and closed workbooks
                                                  If InStr(Replace(chrSrs.Formula, "[", vbNullString), lSource) > 0 Or InStr(chrSrs.Formula, Right$(lSource, Len(lSource) - InStrRev(lSource, "\"))) > 0 Then
                                                      FndChrLink = True
                                                      'write to the report file
                                                      objFSOfile.writeline "Chart Series," & chr.Name & "," & sh.Name & "," & Right$(lSource, Len(lSource) - InStrRev(lSource, "\")) & "," & lSource & ",'" & Replace(chrSrs.Formula, ",", ";")
                                                      Exit For
                                                  End If
                                              Next
                                          End If
                                      Next chrSrs
                       
                                      If chr.Chart.HasTitle Then
                                          If sh.ProtectContents = True Then
                                              ShProt = ShProt & sh.Name & " - " & chr.Name & vbNewLine
                                          Else
                                              chr.Activate
                                              chrTitle = CStr(ExecuteExcel4Macro("GET.FORMULA(""Title"")"))
                                              If InStr(chrTitle, ".xls") <> 0 Then
                                                  For Each lSource In ActiveWorkbook.LinkSources
                                                      'look in open and closed workbooks
                                                      If InStr(Replace(chrTitle, "[", vbNullString), lSource) > 0 Or InStr(chrTitle, Right$(lSource, Len(lSource) - InStrRev(lSource, "\"))) > 0 Then
                                                          FndChrLink = True
                                                          'write to the report file
                                                          objFSOfile.writeline "Chart Title," & chr.Name & "," & sh.Name & "," & Right$(lSource, Len(lSource) - InStrRev(lSource, "\")) & "," & lSource & ",'" & chrTitle
                                                          Exit For
                                                      End If
                                                  Next
                                              End If
                                          End If
                                      End If
                       
                                  Next chr
                       
                                  'Pivot Tables
                                  For Each PivCh In sh.PivotTables
                                      If InStr(PivCh.SourceData, ".xls") > 0 Then
                                          For Each lSource In ActiveWorkbook.LinkSources
                                              If InStr(Replace(PivCh.SourceData, "[", vbNullString), lSource) > 0 Or InStr(PivCh.SourceData, Right$(lSource, Len(lSource) - InStrRev(lSource, "\"))) > 0 Then
                                                  objFSOfile.writeline "Pivot Table," & PivCh.Name & "," & sh.Name & "," & Right$(lSource, Len(lSource) - InStrRev(lSource, "\")) & "," & lSource & ",'" & PivCh.SourceData
                                                  FndPivLink = True
                                                  Exit For
                                              End If
                                          Next
                                      End If
                                  Next
                              Case 3
                                  Set chr1 = Nothing
                                  On Error Resume Next
                                  Set chr1 = sh
                                  On Error GoTo 0
                                  If Not chr1 Is Nothing Then
                                      Application.StatusBar = "Searching charts in sheet " & sh.Name
                                      For Each chrSrs In chr1.SeriesCollection
                                          If InStr(chrSrs.Formula, ".xls") <> 0 Then
                                              For Each lSource In ActiveWorkbook.LinkSources
                                                  'look in open and closed workbooks
                                                  If InStr(Replace(chrSrs.Formula, "[", vbNullString), lSource) > 0 Or InStr(chrSrs.Formula, Right$(lSource, Len(lSource) - InStrRev(lSource, "\"))) > 0 Then
                                                      FndChrLink = True
                                                      'write to the report file
                                                      objFSOfile.writeline "Chart Series,Chart Sheet," & sh.Name & "," & Right$(lSource, Len(lSource) - InStrRev(lSource, "\")) & "," & lSource & ",'" & Replace(chrSrs.Formula, ",", ";")
                                                      Exit For
                                                  End If
                                              Next
                                          End If
                                      Next
                       
                                      If chr1.HasTitle Then
                                          chr1.Activate
                                          chrTitle = CStr(ExecuteExcel4Macro("GET.FORMULA(""Title"")"))
                                          If InStr(chrTitle, ".xls") <> 0 Then
                                              For Each lSource In ActiveWorkbook.LinkSources
                                                  'look in open and closed workbooks
                                                  If InStr(Replace(chrTitle, "[", vbNullString), lSource) > 0 Or InStr(chrTitle, Right$(lSource, Len(lSource) - InStrRev(lSource, "\"))) > 0 Then
                                                      FndChrLink = True
                                                      'write to the report file
                                                      objFSOfile.writeline "Chart Title,Chart Sheet," & sh.Name & "," & Right$(lSource, Len(lSource) - InStrRev(lSource, "\")) & "," & lSource & ",'" & Replace(chrTitle, ",", ";")
                                                      Exit For
                                                  End If
                                              Next
                                          End If
                                      End If
                                  End If
                              Case Else
                              End Select
                              'End If
                          Next sh
                       
                          'Named ranges
                          If ActiveWorkbook.Names.Count = 0 Then
                          Else
                              Application.StatusBar = "Searching range names"
                              For nameCnt = 1 To ActiveWorkbook.Names.Count
                                  If InStr(ActiveWorkbook.Names(nameCnt), ".xls") <> 0 Then
                                      For Each lSource In ActiveWorkbook.LinkSources
                                          If InStr(Replace(ActiveWorkbook.Names(nameCnt), "[", vbNullString), lSource) > 0 Or InStr(ActiveWorkbook.Names(nameCnt), Right$(lSource, Len(lSource) - InStrRev(lSource, "\"))) > 0 Then
                                              FndNameLink = True
                                              'write to the report file
                                              objFSOfile.writeline "Range Name," & "Workbook level," & ActiveWorkbook.Names(nameCnt).Name & "," & Right$(lSource, Len(lSource) - InStrRev(lSource, "\")) & "," & lSource & ",'" & ActiveWorkbook.Names(nameCnt).RefersTo
                                              Exit For
                                          End If
                                      Next
                                      'Name link does not exist in "known" links
                                      If FndNameLink = False Then
                                          FndNameLink = True
                                          objFSOfile.writeline "Range Name," & "Workbook level," & ActiveWorkbook.Names(nameCnt).Name & "," & ActiveWorkbook.Names(nameCnt) & ",'" & Replace(ActiveWorkbook.Names(nameCnt).RefersTo, ",", ";")
                                      End If
                                  End If
                              Next nameCnt
                          End If
                       
                          'Close the report file
                          objFSOfile.Close
                          Set objFSO = Nothing
                       
                          'If at least one cell link was found then open report file
                          If (FndChrLink = FndNameLink = FndRngLink = FndPivLink) And FndRngLink = False Then
                              MsgBox "No formula links found", vbCritical
                          Else
                              Set wb = Workbooks.Open(ReportFile)
                              With wb.Sheets(1)
                                  .Rows("1:2").Font.Bold = True
                                  .Columns("A:F").AutoFit
                                  .[A2].AutoFilter
                              End With
                          End If
                          With Application
                              .StatusBar = vbNullString
                              .DisplayAlerts = True
                          End With
                          If ShProt <> vbNullString Then MsgBox "The following sheets were protected " & vbNewLine & "so these Chart titles could not be searched" & vbNewLine & ShProt, vbCritical
                      End Sub

Open in new window

5
3,799 Views
Dave
CERTIFIED EXPERT

Comments (1)

CERTIFIED EXPERT

Author

Commented:
Hi WaterStreet,

I have updated the into and instructions for how to insert and run the code

The code itself is designed more as a final resource with underlying code available, as opposed to a "how to" guide.  It is relatively complicate, so it would take an advanced coder to maniupulate it. That said it is logically laid out with the major steps commented.

I suggest that one of the Excel PE's such as WebbTubbs or Zorvek take a look if you have any further concerns

Regards

Dave

Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.