PDA

View Full Version : Solved: Mapping Excel Links



bradh_nz
08-03-2007, 03:18 AM
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
08-03-2007, 03:32 AM
Hi

Have a look here:

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

Richard

bradh_nz
08-03-2007, 03:37 AM
Hi, thanks, that just took me to the main menu?

RichardSchollar
08-03-2007, 03:41 AM
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
08-03-2007, 03:51 AM
Thanks, very handy

schles99
11-10-2007, 11:53 AM
This looks like just what I'm looking for, but I'm a newbie at Excel. How do I run this?

Thanks

John