データソースのリンク表示(VBA)

Excelのファイルを開くときに、「このブックには、ほかのデータソースへのリンクが含まれています。」が表示されることがある。どこにリンクがあるかを探すためには、「編集」-「リンクの設定」から調べて検索することとなります。
１つずつ調べるのが面倒なのでVBAで作ってみました。メッセージボックスに結果が表示されます。表示内容をクリップボードに貼ることもできます。
※転載禁止です。

Option Explicit

Public Sub ListupLinkSources()
    Dim c As Collection
    Dim i As Long
    Dim wb As Workbook
    Dim vLinks
    Dim l
    Dim findStr As String
    Dim msg As String
    Dim resultMsg As String
    Dim bFound As Boolean
    
    Set wb = ActiveWorkbook
    vLinks = wb.LinkSources(xlExcelLinks)
    
    If IsEmpty(vLinks) Then
        MsgBox "このブックにはリンクはありません。"
        Exit Sub
    End If
    
    bFound = False
    msg = ""
    For Each l In vLinks
        findStr = createFindString(CStr(l))
        Set c = FindLinkOnWorkbook(wb, findStr)
    
        If c.Count > 0 Then
            For i = 1 To c.Count
                msg = msg & l & ":" & c.Item(i) & vbCrLf
            Next i
            bFound = True
        Else
            msg = msg & l & ":not found" & vbCrLf
        End If
    Next l
    If bFound Then
        resultMsg = msg & vbCrLf & "以上が見つかりました。" & vbCrLf & "クリップボードにコピーしますか？"
    Else
        resultMsg = msg & vbCrLf & "リンクが設定されていません。"
    End If
    
    If MsgBox(resultMsg, vbYesNo) = vbYes Then
        Dim dobj As DataObject
        
        Set dobj = New DataObject
        dobj.Clear
        dobj.SetText msg, 1
        dobj.PutInClipboard
    End If
End Sub

Private Function createFindString(str As String) As String
    Dim pos As Long
    Dim findStr As String
    
    pos = InStrRev(str, "\")
    If pos > 0 Then
        findStr = Left(str, pos) & "[" & Mid(str, pos + 1) & "]"
    Else
        findStr = "[" & str & "]"
    End If
    createFindString = findStr
End Function

Private Function FindLinkOnWorkbook(wb As Workbook, findStr As String) As Collection
    Dim c As Collection
    Dim i As Long
    Dim ws
    Dim resultItems As Collection
    
    Set resultItems = New Collection
        
    For Each ws In wb.Worksheets
        Set c = FindLinkOnWorksheet(wb.Worksheets(ws.Name), findStr)
        If c.Count > 0 Then
            For i = 1 To c.Count
                resultItems.Add ws.Name & ":" & c.Item(i).AddressLocal(False, False)
            Next i
        End If
        Set c = Nothing
    Next ws
    
    Set FindLinkOnWorkbook = resultItems
End Function

Private Function FindLinkOnWorksheet(ws As Worksheet, findStr As String) As Collection
    Dim rFound As Range
    Dim rAfter As Range
    Dim items As Collection
    
    Set items = New Collection
    With ws
        Set rAfter = .Cells(65536, 256)   'Cells(1,1)とするとA1が該当する場合、最初に見つからない？
        Set rFound = .Cells.Find(What:=findStr, _
                                    after:=rAfter, _
                                    LookIn:=xlFormulas, _
                                    lookat:=xlPart, _
                                    searchorder:=xlByRows, _
                                    SearchDirection:=xlNext, _
                                    MatchCase:=False, _
                                    matchbyte:=False, _
                                    SearchFormat:=False)
        Do While Not rFound Is Nothing
            items.Add rFound
            Set rFound = .Cells.FindNext(rFound)
            If items.Count > 1 And items.Item(1) = rFound Then
                Exit Do
            End If
        Loop
    End With
    
    Set FindLinkOnWorksheet = items
End Function