Solved: Mapping Excel Links

[bradh_nz]

Hi
Does anyone know of any code out there that you could run over a selected folder structure that would give you a list of all the excel spreadsheet workbook links.

Essentially this would map the drive and you could troubleshoot any incorrect linking.

Thanks
Brad

[RichardSchollar]

Hi

Have a look here:

http://vbaexpress.com/kb/submitcode.php?kb_id=897

Richard

[bradh_nz]

Hi, thanks, that just took me to the main menu?

[RichardSchollar]

Sorry - it's in a WIP state so presumably there are access limitations for others. This is the code:

Sub ListLinks()
Dim strDirectory 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, lCalc As Long
lCalc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = 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
bSubFolders = False
Set fs = Application.FileSearch
strDirectory = GetFolder()
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
        'Remove the double quotes here if you want Excel to ask you for a password
        'if the file is protected
        Set wb = Workbooks.Open(strFileList(i), False, True, , "", , , , , , False)
        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
Application.Calculation = lCalc
Application.EnableEvents = True
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 GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
 
Function SheetExists(SheetName As String) As Boolean
Dim sName As String
SheetExists = False
On Error Resume Next
sName = ThisWorkbook.Sheets(SheetName).Name
On Error GoTo 0
If Len(sName) > 0 Then SheetExists = True
End Function

Copy it into a new workbook and run the ListLinks sub.

EDIT: this assumes you are using xl2002 or xl2003 (not xl2007 or xl2000 or below).

Richard

[bradh_nz]

Thanks, very handy

[schles99]

This looks like just what I'm looking for, but I'm a newbie at Excel. How do I run this?

Thanks

John