Links to external workbooks

Sparkle, I've written code that will provide you a listing of linked files and, optionally, a listing of the cells containing links. The listing of cells will be hyperlinked to that cell. I've used this many times and it is a real time saver.

Sub Linked_file_listing()
'Written by Barrie Davidson

Dim FilesLinked As Variant
Dim LinkedFilesCount As Integer
Dim SheetCount As Integer
Dim counter As Integer
Dim FileCounter As Integer
Dim LinkAddress As String
Dim LinkedFileName As String
Dim PositionCounter As Integer
Dim PositionRow As Integer
Dim PositionColumn As Integer
Dim FirstOccurrence As String

Application.ScreenUpdating = False
On Error Resume Next
FilesLinked = ActiveWorkbook.LinkSources
If IsError(FilesLinked(1)) = True Then
MsgBox prompt:="No Links Exist", Buttons:=vbInformation + vbOKOnly
Exit Sub
Else
End If
LinkedFilesCount = UBound(FilesLinked)
Sheets(1).Activate
Sheets.Add
Range("A1").Value = "Current list as of " & Format$(Now(), "mmmm d, yyyy")
Range("A2").Select
FileCounter = 1
Do Until FileCounter > LinkedFilesCount
Selection.Value = "LINKED FILE"
Selection.Offset(1, 0).Value = FilesLinked(FileCounter)
Selection.Offset(0, 1).Select
FileCounter = FileCounter + 1
Loop 'Do Until FileCounter > LinkedFilesCount
If MsgBox("Do you want to list each cell containing a link", vbYesNo, _
"Assante Asset Management Ltd.") = vbNo Then
Range("A2:" & Range("A2").End(xlToRight).Address).Select
Selection.EntireColumn.Select
Selection.EntireColumn.AutoFit
Range("A1").Select
Exit Sub
Else
End If
Range("A4").Select
FileCounter = 1
Do Until FileCounter > LinkedFilesCount
LinkedFileName = ""
PositionCounter = 1
Do Until LinkedFileName = "\"
LinkedFileName = Mid(FilesLinked(FileCounter), Len(FilesLinked(FileCounter)) - PositionCounter, 1)
PositionCounter = PositionCounter + 1
Loop 'Do Until LinkedFileName = "\"
LinkedFileName = Mid(FilesLinked(FileCounter), Len(FilesLinked(FileCounter)) - PositionCounter + 2)
Selection.Value = "LINKED FILE CELL LOCATION(es)"
Selection.Offset(1, 0).Select
Sheets(2).Activate
SheetCount = ActiveWorkbook.Sheets.Count
counter = 2
Do Until counter > SheetCount 'Put hyperlinks to each linked cell
Range("A1").Select
FindAddresses:
If IsError(Cells.Find(What:=LinkedFileName, _
After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate) = True Then
Else
FirstOccurrence = ActiveCell.Address
LinkAddress = "'" & ActiveCell.Worksheet.Name & "'!" & ActiveCell.Address
Sheets(1).Activate
ActiveCell.NumberFormat = "@"
ActiveCell.Value = "'" & LinkAddress
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
LinkAddress
ActiveCell.Offset(1, 0).Select
Sheets(counter).Activate
Cells.Find(What:=LinkedFileName, _
After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
Do Until ActiveCell.Address = FirstOccurrence
LinkAddress = "'" & ActiveCell.Worksheet.Name & "'!" & ActiveCell.Address
Sheets(1).Activate
ActiveCell.NumberFormat = "@"
ActiveCell.Value = "'" & LinkAddress
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
LinkAddress
ActiveCell.Offset(1, 0).Select
Sheets(counter).Activate
Cells.Find(What:=LinkedFileName, _
After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
Loop 'Do Until ActiveCell.Address = FirstOccurrence
End If
counter = counter + 1
Sheets(counter).Activate
PositionRow = 0
PositionColumn = 0
Loop 'Do Until Counter > SheetCount

'added this to get named ranges
Sheets(1).Activate
ActiveCell.Offset(1, 0).Activate
ActiveCell.Value = "Named Range(s)"
ActiveCell.Offset(1, 0).Activate
If ActiveWorkbook.Names.Count = 0 Then
Else
For counter = 1 To ActiveWorkbook.Names.Count
If InStr(ActiveWorkbook.Names(counter), LinkedFileName) <> 0 Then
ActiveCell.Value = """" & ActiveWorkbook.Names(counter).Name _
& """" & " refers to " & ActiveWorkbook.Names(counter)
ActiveCell.Offset(1, 0).Select
End If
Next counter
End If
'end of getting named ranges

FileCounter = FileCounter + 1
Sheets(1).Activate
ActiveCell.Offset(0, 1).End(xlUp).Offset(1, 0).Activate
Loop 'Do Until FileCounter > LinkedFilesCount
Sheets(1).Activate
Range("A2:" & Range("A2").End(xlToRight).Address).Select
Selection.EntireColumn.Select
Selection.EntireColumn.AutoFit
Range("A1").Select
Application.ScreenUpdating = True

End Sub

Regards,
Barrie
Barrie Davidson

This works very well! Thanx