Excel - Marvin

Disculpa pero creo que tu querias el macro que checa los links de todos los archivos de excel en la carpeta y subcarpetas y te crea una base de datos sobre estos... bueno aqui esta el codigo, saludos...

(nota: tengo entendido que este macro no funciona correctamente en xl2007 pero no hay ningun problema en xl 2003 o anteriores).

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

Muchas gracias amigo Oscar, te lo agradezco mucho.

Salu2