Summary / List of Linked Source Files?

westjelly

Board Regular
Joined
Jul 5, 2005
Messages
50
I'm working with a massive web of spreadsheets and trying to trace what is coming from where. I see references to at least 15-20 different files. The person who maintains this file is away for at least a week and I'd like to get a better handle on how things are linked.

I'll be working on a database to replace this big web, so I want to know what all I'll need to import/export as far as data goes.

Is there a procedure that could give me a list of linked files, file location, etc?

Ideally, I could get some sort of table that included a cell and which cells it references or something like that, but just a quick summary would be something. I can go to Edit-->Links but would like a quick way to copy this information out.
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Hi WestJelly

You can copy and paste the following code into a new workbook, set a reference to Microsoft Scripting Runtime library within the VBE (Tools>References) and then run the macro from within Excel (Tools>Macro>Macros) and navigate to the folder that you want to list external links of the workbooks in said folder. Give it a try. Note this effectively only inserts a list (as available from Edit>Links) but it does do it for all workbooks in a folder location. The actual cells with these links are not identified.

Code:
Option Explicit 
Public Type BROWSEINFO 
    hOwner As Long 
    pidlRoot As Long 
    pszDisplayName As String 
    lpszTitle As String 
    ulFlags As Long 
    lpfn As Long 
    lParam As Long 
    iImage As Long 
End Type 
 
Declare Function SHGetPathFromIDList Lib "shell32.dll" _ 
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _ 
As Long 
 
Declare Function SHBrowseForFolder Lib "shell32.dll" _ 
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 
 
Sub ListLinks() 
     
     'Go Tools>References and set a reference to Microsoft Scripting Runtime
     
    Dim strDirectory As String, msg As String, bSubFolders As Boolean, arrTemp, k As Integer 
    Dim strFileList() As String, fs As FileSearch, i As Integer, j As Long, iErrorResponse As Integer 
    Dim wb As Workbook, wsLinks As Worksheet, wbLinks As Workbook, wsErrors As Worksheet 
    Dim m As Integer, iSubs As Integer 
     
    Application.Calculation = xlCalculationManual 
    Application.DisplayAlerts = False 
    Application.ScreenUpdating = False 
     
    Set wbLinks = ThisWorkbook 
     
    If SheetExists("Links") Then 
        Set wsLinks = wbLinks.Sheets("Links") 
    Else 
        Set wsLinks = wbLinks.Worksheets.Add 
        wsLinks.Name = "links" 
    End If 
    With wsLinks 
        .Cells.ClearContents 
        .Rows(1).Font.Bold = True 
        .Cells(1, 1) = "Path" 
        .Cells(1, 2) = "FileName" 
        .Cells(1, 3) = "External Links" 
        .Cells(1, 4) = "Link Detail" 
    End With 
     
    If SheetExists("Errors") Then 
        Set wsErrors = wbLinks.Sheets("Errors") 
    Else 
        Set wsErrors = wbLinks.Worksheets.Add 
        wsErrors.Name = "Errors" 
    End If 
     
    With wsErrors 
        .Cells.ClearContents 
        .Rows(1).Font.Bold = True 
        .Cells(1, 1) = "FullName" 
        .Cells(1, 2) = "Error" 
    End With 
     
    msg = "Please select a folder." 
     
    bSubFolders = False 
     
    Set fs = Application.FileSearch 
     
    strDirectory = GetDirectory(msg) 
     
    iSubs = MsgBox("Include workbooks in sub-folders?", vbYesNo, "Sub-Folders") 
    If iSubs = vbYes Then bSubFolders = True 
     
    With fs 
        .LookIn = strDirectory 
        .SearchSubFolders = bSubFolders 
        .FileType = msoFileTypeExcelWorkbooks 
        If .Execute > 0 Then 
            ReDim strFileList(.FoundFiles.Count - 1) 
            For i = 0 To .FoundFiles.Count - 1 
                strFileList(i) = .FoundFiles(i + 1) 
            Next i 
        Else: MsgBox "No Excel Workbooks found": Exit Sub 
        End If 
    End With 
    j = 2 
    m = 2 
    For i = 0 To UBound(strFileList) 
        On Error Resume Next 
        Set wb = Workbooks.Open(strFileList(i), False, True, , "", , , , , , False) 'Remove the double quotes here if you want Excel to ask you for a password if the file is protected
        If Err > 0 Then Goto Err_Handler 
        On Error Goto 0 
        arrTemp = wb.LinkSources(xlExcelLinks) 
        With wsLinks 
            If IsEmpty(arrTemp) Then 
                .Cells(j, 1) = Left(strFileList(i), InStrRev(strFileList(i), "\")) 
                .Cells(j, 2) = Right(strFileList(i), Len(strFileList(i)) - InStrRev(strFileList(i), "\")) 
                .Cells(j, 3) = False 
                .Cells(j, 4) = "N/A" 
                j = j + 1 
            Else 
                For k = 1 To UBound(arrTemp) Step 1 '1-based array
                    .Cells(j + k - 1, 1) = Left(strFileList(i), InStrRev(strFileList(i), "\")) 
                    .Cells(j + k - 1, 2) = Right(strFileList(i), Len(strFileList(i)) - InStrRev(strFileList(i), "\")) 
                    .Cells(j + k - 1, 3) = True 
                    .Cells(j + k - 1, 4) = arrTemp(k) 
                Next k 
                j = j + UBound(arrTemp) 
            End If 
        End With 
        Set arrTemp = Nothing 
        wb.Close 
next_wb: 
    Next i 
     
     
    wsLinks.Columns("A:C").EntireColumn.AutoFit 
    wsErrors.Columns("A:B").EntireColumn.AutoFit 
     
    If wsErrors.Range("a2") <> "" Then 
        iErrorResponse = MsgBox("View Exceptions Report?", vbYesNo, "Errors encountered") 
        If iErrorResponse = vbYes Then wsErrors.Activate: Exit Sub 
    End If 
    wsLinks.Activate 
    Exit Sub 
     
     
Err_Handler: 
    With wsErrors 
        .Cells(m, 1) = strFileList(i) 
        .Cells(m, 2) = "Error Number: " & Err.Number & " Error Description: " & Err.Description 
    End With 
    m = m + 1 
    Err.Clear 
    Goto next_wb 
End Sub 
 
 
 
Function GetDirectory(Optional msg) As String 
    Dim bInfo As BROWSEINFO 
    Dim path As String 
    Dim r As Long, x As Long, pos As Integer 
     
    bInfo.pidlRoot = 0& 
     
    If IsMissing(msg) Then 
        bInfo.lpszTitle = "Select a folder." 
    Else 
        bInfo.lpszTitle = msg 
    End If 
     
    bInfo.ulFlags = &H1 
     
    x = SHBrowseForFolder(bInfo) 
     
    path = Space$(512) 
    r = SHGetPathFromIDList(ByVal x, ByVal path) 
    If r Then 
        pos = InStr(path, Chr$(0)) 
        GetDirectory = Left(path, pos - 1) 
    Else 
        GetDirectory = "" 
    End If 
End Function 
Function SheetExists(SheetName As String) As Boolean 
    Dim ws As Worksheet 
    SheetExists = False 
    On Error Resume Next 
    Set ws = ThisWorkbook.Sheets(SheetName) 
    If Err = 0 Then SheetExists = True 
End Function

Best regards

Richard
 
Upvote 0
Smitty,

Thanks for the link. It appears (unless I'm overlooking something), that the JWalk Add-In deals with the named ranges. I used it on my master file and it didn't show any links.


Richard,

Thanks. I threw the code into a module and fired it up. It gave me a list of 380 links in a sheet that showed the file, a true/false for the existence of external links, and then a separate line for each file linked. Whew!
 
Upvote 0

Forum statistics

Threads
1,226,616
Messages
6,192,040
Members
453,691
Latest member
CT30

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top