Nikhil9999
10-29-2017, 08:16 AM
Sir, I have a code and require it be tweaked. I found the code on google. The code finds all external links whether in Formula/Chart/Name name manager and lists it in a different file at the location specified in the code. I want it to generate the output in the same file. Can this be done? Thanks
Code is as follows -
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
' 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:\Users\Nikhil Kumar\Desktop\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
Code is as follows -
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
' 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:\Users\Nikhil Kumar\Desktop\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