VBA - Detecting external references to workbook

So a great question came up on StackOverflow about detecting external references to workbooks. Like most I thought the Trace precendents toolbar button would get one there but one has too double click on an external link icon. Equally, the Range.Precedents property does not report cells on an external workbook. So initially I was stumped.

The solution is examine a Workbooks LinkSources and then use that as a search term (you'll need to chop the path and enclose in square brackets). Here is the code.

Option Explicit

'---------------------------------------------------------------------------------------
' Procedure : Investigate
' DateTime  : 06/02/2018 14:40
' Author    : Simon
' Purpose   : Start execution here.  There is some setup code
'---------------------------------------------------------------------------------------
' Arguments :
'    arg1      : arg1 description
'
Sub Investigate()

    '**************************************************
    ' START of Experiment setup code
    '**************************************************
    Dim wb1 As Excel.Workbook, wb2 As Excel.Workbook

    GetOrCreateMyTwoWorbooks "Book1", "SimonSub1", wb1, "Book2", "SimonSub2", wb2


    wb1.Worksheets(1).Range("a1").Formula = "=2^4"
    
    
    wb2.Worksheets(1).Range("a1").Formula = "=2^2"
    wb2.Worksheets(1).Range("b1").Formula = "=3^2"
    wb2.Worksheets(1).Range("a2").FormulaR1C1 = "=[" & wb1.Name & "]Sheet1!R1C1/r1c1*r1c2"

    '**************************************************
    ' END of Experiment setup code
    '**************************************************

    '**************************************************
    '* now the real logic begins
    '**************************************************
    
    Dim dicLinkSources As Scripting.Dictionary
    Set dicLinkSources = LinkSources(wb2)
    
    '* get all the cells containing formulae in the worksheet we're interested in
    Dim rngFormulaCells As Excel.Range
    Set rngFormulaCells = wb2.Worksheets(1).UsedRange.SpecialCells(xlCellTypeFormulas)
    
    '* set up results container (one could report as we find them but I like to collate)
    Dim dicExternalWorksheetPrecedents As Scripting.Dictionary
    Set dicExternalWorksheetPrecedents = New Scripting.Dictionary
    
    '* loop throught the subset of cells on the worksheet that have formulae
    Dim rngFormulaCellsLoop As Excel.Range
    For Each rngFormulaCellsLoop In rngFormulaCells
    
        Dim sFormula As String
        sFormula = rngFormulaCellsLoop.Formula  '* I like a copy in my locals window
        
        '* search for all the link sources (experiment has only one, chance are you'll have many)
        Dim vSearchLoop As Variant
        For Each vSearchLoop In dicLinkSources.Items
            If VBA.InStr(1, sFormula, vSearchLoop, vbTextCompare) > 0 Then
            
                '* we found one, add to collated results
                dicExternalWorksheetPrecedents.Add wb2.Name & "!" & wb2.Worksheets(1).Name & "!" & rngFormulaCellsLoop.Address, vSearchLoop
            
            End If
        Next vSearchLoop
        
    Next
    
    '*print collated results
    Dim lResultLoop As Long
    For lResultLoop = 0 To dicExternalWorksheetPrecedents.Count - 1
        Debug.Print "Cell at " & dicExternalWorksheetPrecedents.Keys()(lResultLoop) & " has external workbook source of " & dicExternalWorksheetPrecedents.Items()(lResultLoop)
    
    Next lResultLoop
    
    
    Stop
End Sub

'---------------------------------------------------------------------------------------
' Procedure : LinkSources
' DateTime  : 06/02/2018 14:38
' Author    : Simon
' Purpose   : To acquire list of link sources and more importantly the search term
'             we're going to see to look for external workbooks
'---------------------------------------------------------------------------------------
' Arguments :
'   [in] wb         : The workbook we want report on
'   [out,retval]    : returns a dictionary with the lik sources in the keys and search term in item
'
Function LinkSources(ByVal wb As Excel.Workbook) As Scripting.Dictionary
 
    Static fso As Object
    If fso Is Nothing Then Set fso = VBA.CreateObject("Scripting.FileSystemObject")

    Dim dicLinkSources As Scripting.Dictionary
    Set dicLinkSources = New Scripting.Dictionary
    
    Dim vLinks As Variant
    vLinks = wb.LinkSources(XlLink.xlExcelLinks)
    
    If Not IsEmpty(vLinks) Then
        Dim lIndex As Long
        For lIndex = LBound(vLinks) To UBound(vLinks)
        
            Dim sSearchTerm As String
            sSearchTerm = ""
            
            If fso.FileExists(vLinks(lIndex)) Then
                Dim fil As Scripting.file
                Set fil = fso.GetFile(vLinks(lIndex))
                    
                '* this is what we'll search for in the cell formulae
                sSearchTerm = "[" & fil.Name & "]"
                
            End If
        
            dicLinkSources.Add vLinks(lIndex), sSearchTerm
        
        Next lIndex
    End If
    Set LinkSources = dicLinkSources
End Function


'*****************************************************************************************************************
'                                         __                                __
'_____  ______ ___________ ____________ _/  |_ __ __  ______   ______ _____/  |_ __ ________
'\__  \ \____ \\____ \__  \\_  __ \__  \\   __\  |  \/  ___/  /  ___// __ \   __\  |  \____ \
' / __ \|  |_> >  |_> > __ \|  | \// __ \|  | |  |  /\___ \   \___ \\  ___/|  | |  |  /  |_> >
'(____  /   __/|   __(____  /__|  (____  /__| |____//____  > /____  >\___  >__| |____/|   __/
'     \/|__|   |__|       \/           \/                \/       \/     \/           |__|
'
'*****************************************************************************************************************
'* this is just something to setup the experiment, you won't need this hence the big banner  :)
'*
Public Sub GetOrCreateMyTwoWorbooks(ByVal sWbName1 As String, ByVal sSubDirectory1 As String, ByRef pwb1 As Excel.Workbook, _
                                    ByVal sWbName2 As String, ByVal sSubDirectory2 As String, ByRef pwb2 As Excel.Workbook)

    Static fso As Object
    If fso Is Nothing Then Set fso = VBA.CreateObject("Scripting.FileSystemObject")
    
    On Error Resume Next
    Set pwb1 = Application.Workbooks.Item(sWbName1)
    Set pwb2 = Application.Workbooks.Item(sWbName2)
    On Error GoTo 0
    
    If pwb1 Is Nothing Then
        Set pwb1 = Application.Workbooks.Add
        
        Dim sSubDir1 As String
        sSubDir1 = fso.BuildPath(Environ$("tmp"), sSubDirectory1)
        
        If Not fso.FolderExists(sSubDir1) Then fso.CreateFolder (sSubDir1)
        
        Dim sSavePath1 As String
        sSavePath1 = fso.BuildPath(sSubDir1, sWbName1)
        
        pwb1.SaveAs sSavePath1
    End If
    
    If pwb2 Is Nothing Then
        Set pwb2 = Application.Workbooks.Add
        
        Dim sSubDir2 As String
        sSubDir2 = fso.BuildPath(Environ$("tmp"), sSubDirectory2)
        
        If Not fso.FolderExists(sSubDir2) Then fso.CreateFolder (sSubDir2)
        
        
        Dim sSavePath2 As String
        sSavePath2 = fso.BuildPath(sSubDir2, sWbName2)
        
        pwb2.SaveAs sSavePath2
    End If
    

End Sub