VBA Code


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
Dim AddressRow As Long 'used for putting hyperlink in listing sheet

Application.ScreenUpdating = False
FilesLinked = ActiveWorkbook.LinkSources
If IsArray(FilesLinked) = False Then
    MsgBox prompt:="No Links Exist", Buttons:=vbInformation + vbOKOnly
    Exit Sub
End If
LinkedFilesCount = UBound(FilesLinked)

'Check for LinkListing worksheet
On Error Resume Next
If ActiveWorkbook.Worksheets("LinkListing").Index > 0 Then
    Application.DisplayAlerts = False
    ActiveWorkbook.Worksheets("LinkListing").Delete
    Application.DisplayAlerts = True
End If
On Error GoTo 0

Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "LinkListing"
Range("A1").Value = "Current list as of " & Format$(Now(), "mmmm d, yyyy")
FileCounter = 1

'Enter the linked file names
Do Until FileCounter > LinkedFilesCount
    Cells(2, FileCounter).Value = "LINKED FILE"
    Cells(3, FileCounter).Value = FilesLinked(FileCounter)
    FileCounter = FileCounter + 1
Loop 'Do Until FileCounter > LinkedFilesCount




If MsgBox("Do you want to list each cell containing a link", vbYesNo, _
    "Barrie's Link Listing") = vbNo Then
    Range("A2:" & Range("A2").End(xlToRight).Address).EntireColumn.AutoFit
    Range("A1").Select
    Exit Sub
End If


'Listing each cell linked

FileCounter = 1
Do Until FileCounter > LinkedFilesCount
    LinkedFileName = FilesLinked(FileCounter)
    PositionCounter = 1
    If InStr(LinkedFileName, "/") = 0 Then
        Do Until LinkedFileName = "\"
            LinkedFileName = Mid(FilesLinked(FileCounter), _
                Len(FilesLinked(FileCounter)) - PositionCounter, 1)
            PositionCounter = PositionCounter + 1
        Loop 'Do Until LinkedFileName = "\"
    Else
        Do Until LinkedFileName = "/"
            LinkedFileName = Mid(FilesLinked(FileCounter), _
                Len(FilesLinked(FileCounter)) - PositionCounter, 1)
            PositionCounter = PositionCounter + 1
        Loop 'Do Until LinkedFileName = "/"
    End If
    LinkedFileName = Mid(FilesLinked(FileCounter), Len(FilesLinked(FileCounter)) - PositionCounter + 2)
    Sheets("LinkListing").Cells(4, FileCounter).Value = "LINKED FILE CELL LOCATION(es)"
    SheetCount = ActiveWorkbook.Sheets.Count
    Counter = 2
    Do Until Counter > SheetCount 'Put hyperlinks to each linked cell
            Sheets(Counter).Activate
            FirstOccurrence = "A1"
            AddressRow = 5
FindAddresses:
            On Error Resume Next
            If IsError(Cells.Find(What:=LinkedFileName, _
                After:=Range(FirstOccurrence), LookIn:=xlFormulas, LookAt _
                :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False).Activate) = True Then
            On Error GoTo 0
            Else
                FirstOccurrence = ActiveCell.Address
                LinkAddress = "'" & ActiveCell.Worksheet.Name & "'!" & ActiveCell.Address
                Sheets("LinkListing").Cells(AddressRow, FileCounter).NumberFormat = "@"
                Sheets("LinkListing").Cells(AddressRow, FileCounter).Value = "'" & LinkAddress
                Sheets("LinkListing").Hyperlinks.Add Anchor:=Sheets("LinkListing").Cells(AddressRow, FileCounter), Address:="", SubAddress:= _
                    LinkAddress
                AddressRow = AddressRow + 1
                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("LinkListing").Cells(AddressRow, FileCounter).NumberFormat = "@"
                    Sheets("LinkListing").Cells(AddressRow, FileCounter).Value = "'" & LinkAddress
                    Sheets("LinkListing").Hyperlinks.Add Anchor:=Sheets("LinkListing").Cells(AddressRow, FileCounter), Address:="", SubAddress:= _
                        LinkAddress
                    AddressRow = AddressRow + 1
                    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
        PositionRow = 0
    Loop 'Do Until Counter > SheetCount
    
'Get named ranges
    AddressRow = Sheets("LinkListing").Cells(65536, FileCounter).End(xlUp).Row + 2
    Sheets("LinkListing").Cells(AddressRow, FileCounter).Value = "Named Range(s)"
    AddressRow = AddressRow + 1
    
    If ActiveWorkbook.Names.Count = 0 Then
    Else
        For Counter = 1 To ActiveWorkbook.Names.Count
            If InStr(ActiveWorkbook.Names(Counter), LinkedFileName) <> 0 Then
                Sheets("LinkListing").Cells(AddressRow, FileCounter).Value = """" & ActiveWorkbook.Names(Counter).Name _
                    & """" & " refers to " & ActiveWorkbook.Names(Counter)
                AddressRow = AddressRow + 1
            End If
        Next Counter
    End If
'end of getting named ranges
    
    FileCounter = FileCounter + 1
Loop 'Do Until FileCounter > LinkedFilesCount

Sheets("LinkListing").Range("A2:" & _
    Sheets("LinkListing").Range("A2").End(xlToRight).Address).EntireColumn.AutoFit
Sheets("LinkListing").Activate
Range("A1").Select
Application.ScreenUpdating = True


End Sub