ID: 972

	[x] Attachment Details

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

brettdj

Posted on 06/17/09 at 11:22 PM

1 of 1 members found this article helpful

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

linked-output.bmp (751 KB) (File Type Details)

linked file output

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
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

Zone:

Microsoft Excel Spreadsheet Software

Tags:

Excel, Links, VBA, name range, formulas, file scripting object, open closed workbooks

Category:

Resource

Most Helpful Articles:

06/20/09 05:25 AM, ID: 1726

brettdj:

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

Please Login or Register to post a comment.

1. tigermatt 36,200
2. harfang 29,600
3. gr8gonzo 27,200
4. alainbryden 26,800
5. mwvisa1 24,700
6. mark_wills 23,750
7. DanRollins 20,650
8. Qlemo 15,050
9. ValentinoV 14,950
10. dhwake 11,250
11. angelIII 11,150
12. rpggamer... 10,850
13. LeeTutor 10,300
14. jason1178 9,900
15. JDettman 9,750
16. lherrou 9,700
17. keith_ala... 9,300
18. BMilneSLO 6,200
19. HonorGod 5,650
20. abolinhas 5,450
21. masmus 5,400
22. shauncro... 5,250
23. srikanthm... 5,100
24. matthews... 4,800
25. Bobaran98 4,750

1. tigermatt 39,500
2. harfang 29,600
3. gr8gonzo 27,200
4. alainbryden 26,800
5. mwvisa1 25,250
6. mark_wills 23,750
7. DanRollins 20,650
8. Qlemo 15,550
9. ValentinoV 14,950
10. dhwake 11,250
11. angelIII 11,150
12. rpggamer... 10,850
13. JDettman 10,450
14. LeeTutor 10,300
15. jason1178 9,900
16. lherrou 9,700
17. keith_ala... 9,300
18. BMilneSLO 6,200
19. HonorGod 5,650
20. abolinhas 5,450
21. masmus 5,400
22. shauncro... 5,250
23. srikanthm... 5,100
24. matthews... 4,800
25. Bobaran98 4,750