VBA Code for finding all external links in an Excel workbook

This code will report on all links in the current active workbook and open a new workbook with a report of the links. It includes flags for links to files that are not found. The workbook will named as the workbook being checked with "+LINKS" appended.

It is intended to be run from a QAT button, so that's why it uses ActiveWorkbook. It can be adapted to open any desired workbook with a File Open dialog.

The code below is v2 updated 9/21/2015 from the original post.

Option Explicit

Const FileNamePattern = "\[[^]]*\][^\[\]/\\!]*!"

Sub FindAllLinks()

   Dim i                As Integer
   Dim LinkReportWS         As Worksheet
   Dim ReportRow    As Long
   Dim CheckingWB As Workbook
   Dim Root As String
   Dim ExtFileName As String
   
   Dim LinkReport As Workbook
   
   
   Set CheckingWB = ActiveWorkbook
   
   Set LinkReport = Workbooks.Add
   Root = Replace(CheckingWB.Name, "." & Mid(CheckingWB.Name, InStrRev(CheckingWB.Name, ".") + 1), "")
   LinkReport.SaveAs CheckingWB.path & "\" & Root & "+LINKS.xlsx"
   
   Set LinkReportWS = LinkReport.Worksheets(1)
   
   ReportRow = 1
   ExternalCellLinks CheckingWB, LinkReportWS, ReportRow
   
   ReportRow = ReportRow + 2
   DefinedNames CheckingWB, LinkReportWS, ReportRow
   
   ReportRow = ReportRow + 2
   CF CheckingWB, LinkReportWS, ReportRow
   
   LinkReportWS.Cells.EntireColumn.AutoFit
   LinkReportWS.Columns("C:C").ColumnWidth = 50
   
   MsgBox "Finished."

End Sub

' Report on external links in cell formulas
Private Sub ExternalCellLinks(CheckingWB As Workbook, LinkReportWS As Worksheet, ReportRow As Long)

   Dim aLinks           As Variant
   Dim WS            As Worksheet
   Dim Found As Range, FirstFound As Range
   Dim ExtFileNameReport As String
   Dim Count As Long

   
   LinkReportWS.Cells(ReportRow, "A") = "Worksheet"
   LinkReportWS.Cells(ReportRow, "B") = "Cell"
   LinkReportWS.Cells(ReportRow, "C") = "Formula"
   LinkReportWS.Cells(ReportRow, "D") = "Bad file references"
   LinkReportWS.Rows(ReportRow).Font.Bold = True
 
   ' Quick way to find out if links exist
   aLinks = CheckingWB.LinkSources(xlExcelLinks)
   If Not IsEmpty(aLinks) Then
      'there are links somewhere in the workbook
      
      For Each WS In CheckingWB.Worksheets
     
         ' It's a bit quicker to use Find instead of checking every cell
         ' individually, but checking for "[" is not a definitive test for
         ' an external file name; this is just a weeding out process
         Set Found = WS.UsedRange.Find("[", LookIn:=xlFormulas, lookat:=xlPart)
         If Not Found Is Nothing Then
            Set FirstFound = Found
            Do
               If HasExtFileNames(Found.Formula) Then
               
                  Count = Count + 1
                  ReportRow = ReportRow + 1
                  LinkReportWS.Range("A" & ReportRow) = WS.Name
                  LinkReportWS.Range("B" & ReportRow) = Found.Address
                  LinkReportWS.Range("C" & ReportRow) = "'" & Found.Formula
   
                  ' Test external file name(s)
                  ExtFileNameReport = BadFileNameReport(ExtFileNames(Found.Formula))
                  If ExtFileNameReport <> "" Then
                     LinkReportWS.Cells(ReportRow, "D") = ExtFileNameReport
                  End If
               
               End If
               
            Loop Until FirstFound.Address = Found.Address
         End If
         
      Next WS
   End If
   ReportRow = ReportRow + 1
   LinkReportWS.Range("A" & ReportRow) = Count & " external links detected in cell formulas."
End Sub

Private Sub DefinedNames(CheckingWB As Workbook, LinkReportWS As Worksheet, ReportRow As Long)

   
   Dim ExtFileNameReport As String
   Dim WS            As Worksheet
   Dim DefinedName As Name
   Dim NameFormula As String
   Dim Count As Long
   
   
   LinkReportWS.Cells(ReportRow, "B") = "Defined Name"
   LinkReportWS.Cells(ReportRow, "C") = "Formula"
   LinkReportWS.Rows(ReportRow).Font.Bold = True
  
   ' Now check name definitions
   For Each DefinedName In CheckingWB.Names
   
      NameFormula = DefinedName.RefersTo
      If HasExtFileNames(NameFormula) Then
         Count = Count + 1
         ReportRow = ReportRow + 1
         LinkReportWS.Range("B" & ReportRow) = DefinedName.Name
         LinkReportWS.Range("C" & ReportRow) = "'" & NameFormula
         ' Test external file name(s)
         ExtFileNameReport = BadFileNameReport(ExtFileNames(NameFormula))
         If ExtFileNameReport <> "" Then
            LinkReportWS.Range("D" & ReportRow) = ExtFileNameReport
         End If
     End If
   Next DefinedName
   
   ReportRow = ReportRow + 1
   LinkReportWS.Range("A" & ReportRow) = Count & " external links detected in defined names."

End Sub

Private Sub CF(CheckingWB As Workbook, LinkReportWS As Worksheet, ReportRow As Long)

   Dim WS            As Worksheet
   Dim FC As FormatCondition
   Dim ExtFileNameReport As String
   Dim CFRuleIndex As Long
   Dim Count As Long
   
   
   
   'LinkReportWS.Cells(ReportRow, "B") = "Conditional Formatting"
   LinkReportWS.Cells(ReportRow, "C") = "Conditional Formatting Formula"
   LinkReportWS.Rows(ReportRow).Font.Bold = True
   
   ' Now check conditional formatting formulas
      For Each WS In CheckingWB.Worksheets
         For CFRuleIndex = 1 To WS.Cells.FormatConditions.Count
         
            ' Some types of rules are not assignable from the
            ' collection to a FormatCondition object. One such
            ' is Graded Color Scale. The assignment will cause a
            ' Type Mismatch error to be raised. This could be a
            ' VBA bug. The workaround is to ignore that rule.
             If WS.Cells.FormatConditions(CFRuleIndex).Type <> xlColorScale Then
                Set FC = WS.Cells.FormatConditions(CFRuleIndex)
   
               If HasExtFileNames(FC.Formula1) Then
                  ReportRow = ReportRow + 1
                  Count = Count + 1
                  LinkReportWS.Range("A" & ReportRow) = WS.Name
                  LinkReportWS.Range("C" & ReportRow) = "'" & FC.Formula1
                  ' Report on bad external file name(s)
                  ExtFileNameReport = BadFileNameReport(ExtFileNames(FC.Formula1))
                  If ExtFileNameReport <> "" Then
                     LinkReportWS.Range("D" & ReportRow) = ExtFileNameReport
                  End If
               End If
               
               ' An attempt to reference Formula2 for a FormatCondition of type xlExpression
               ' will raise an Application error. This occurs even with
               '   On Error Resume Next
               ' in effect. The If check here is a workaround.
               If FC.Type <> xlExpression Then
                  On Error Resume Next ' error if Formula2 does not exist
                  If HasExtFileNames(FC.Formula2) Then
                     If Err.number = 0 Then
                        ReportRow = ReportRow + 1
                        Count = Count + 1
                        LinkReportWS.Range("A" & ReportRow) = WS.Name
                        LinkReportWS.Range("C" & ReportRow) = "'" & FC.Formula1
                        ' Report on bad external file name(s)
                        ExtFileNameReport = BadFileNameReport(ExtFileNames(FC.Formula2))
                        If ExtFileNameReport <> "" Then
                           LinkReportWS.Range("D" & ReportRow) = ExtFileNameReport
                        End If
                     End If
                  End If
                  On Error GoTo 0
               End If
               
            End If
            
         Next CFRuleIndex ' FC
         
      Next WS
   ReportRow = ReportRow + 1
   LinkReportWS.Range("A" & ReportRow) = Count & " external links detected in conditional formatting formulas."

Exit Sub

End Sub
Public Function BadFileNameReport(FileNames() As String) As String

   Dim i As Long
   
   On Error GoTo EmptyList
   
   For i = LBound(FileNames) To UBound(FileNames)
      If InvalidFile(FileNames(i)) Then
         BadFileNameReport = BadFileNameReport & FileNames(i) & "; "
      End If
   Next i
   Exit Function
   
EmptyList:
   If Err.number = 9 Then ' subscript error
      ' FileNames has no elements
      BadFileNameReport = ""
   Else
      Err.Raise Err.number, Err.Source, Err.Description ' something we don't know how to handle, re-raise error
   End If
   
End Function

' Parse FormulaString and return an array of external file names
Public Function ExtFileNames(FormulaString As String) As String()

   Dim objRegEx  As Object  ' regular expression object
   Dim o         As Variant ' object for iteration
   Dim i         As Long    ' index into result array
   Dim Result    As Variant ' result array from regexp evaluation
   Dim ReturnA() As String  ' array of file name strings to return
   
   Set objRegEx = CreateObject("VBScript.RegExp")
   
   objRegEx.Global = True
   objRegEx.Pattern = FileNamePattern
   Set Result = objRegEx.Execute(FormulaString)
   
   i = 0
   objRegEx.Pattern = "\[([^]]*)\][^\[\]/\\!]*!"
   For Each o In Result
      i = i + 1
      ReDim Preserve ReturnA(0 To i)
      ReturnA(i) = objRegEx.Replace(o, "$1") ' extract the file name
   Next o
   
   ExtFileNames = ReturnA
    
End Function

' Parse FormulaString and determine if it contains any file names
Public Function HasExtFileNames(FormulaString As String) As Boolean

   Dim objRegEx  As Object  ' regular expression object
   
   Set objRegEx = CreateObject("VBScript.RegExp")
   
   objRegEx.Global = True
   objRegEx.Pattern = FileNamePattern
   HasExtFileNames = objRegEx.test(FormulaString)

End Function

Public Function InvalidFile(FullPath As String) As Boolean

   If InStr(FullPath, "\") > 0 Then
      InvalidFile = (Dir(FullPath) = "")
   Else
      InvalidFile = (Dir(ActiveWorkbook.path & "\" & FullPath) = "")
   End If
   
End Function