VBA Express : Excel - Find links in the ActivWorkbook (formulas, range names, charts and PivotTables)

Excel

Find links in the ActivWorkbook (formulas, range names, charts and PivotTables)

Ease of Use

Intermediate

Version tested with

2003

Submitted by:

brettdj

Description:

A csv report file showing the type, location and source of any link is generated

Discussion:

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.

Code:

instructions for use

			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

How to use:

1. Copy above code.
2. In Excel press Alt + F11 to enter the VBE.
3. Press Ctrl + R to show the Project Explorer.
4. Right-click desired file on left.
5. Choose Insert -Module.
6. Paste code into the right pane.
7. Press Alt + Q to close the VBE.
8. Select the Workbook that you want the code to interrogate
9. Press Alt + F8, select 'ListLinks', press Run.

Test the code:

1. From an existing workbook, save first.
2. Press Alt + F8.
3. Choose 'ListLinks'.
4. Press 'Run'.
5. If any links exist a new file, "LinkReport.csv" will be generated with a links report

Sample File:

No Attachment

Approved by Oorang

This entry has been viewed 468 times.