search驱动器的Excel的依赖关系

我目前正在简化公司的文件结构。 这是一团糟。 目前我正在做财务部门，这个部门在excel文件之间有一定的依赖关系。 这些文件我无法迁移到新的结构，因为位置更改和依赖项丢失。

因此，我正在寻找一个工具来扫描文件夹及其子文件夹的Excel依赖项。 我想列举这些，并说：嘿家伙，这些文件呢？

有任何想法吗？

Answer 1

下面的代码

• 打开位于或低于由strStartFolder指定的目录（即“C：\ temp”）中的每个文件，在本例中使用recursionDir
• 在每个文件中查找任何文件链接
• 使用数组来保存然后填充最终的结果

请在strStartFolder更改path以适应

此代码以前作为另一论坛上的文章发布

 Option Explicit Public StrArray() Public lngCnt As Long Public Sub Main() Dim objFSO As Object Dim objFolder As Object Dim WB As Workbook Dim ws As Worksheet Dim strStartFolder As String 'Setup Application for the user With Application .ScreenUpdating = False .DisplayAlerts = False End With 'reset public variables lngCnt = 0 ReDim StrArray(1 To 4, 1 To 1000) strStartFolder = "c:\temp" Set objFSO = CreateObject("Scripting.FileSystemObject") ' Format output sheet Set WB = Workbooks.Add(1) Set ws = WB.Worksheets(1) ws.[a1] = Now() ws.[a2] = strStartFolder ws.[a1:a3].HorizontalAlignment = xlLeft ws.[A4:D4].Value = Array("Folder", "File", "Linked File", "Linked File Path") ws.Range([a1], [c4]).Font.Bold = True ws.Rows(5).Select ActiveWindow.FreezePanes = True Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(strStartFolder) ' Start the code to gather the files ShowSubFolders objFolder, True ShowSubFolders objFolder, False If lngCnt > 0 Then ' Finalise output With ws.Range(ws.[a5], ws.Cells(5 + lngCnt - 1, 4)) .Value2 = Application.Transpose(StrArray) .Offset(-1, 0).Resize(Rows.Count - 3, 4).AutoFilter .Offset(-4, 0).Resize(Rows.Count, 4).Columns.AutoFit End With ws.[a1].Activate Else MsgBox "No files found!", vbCritical WB.Close False End If ' tidy up Set objFSO = Nothing With Application .ScreenUpdating = True .DisplayAlerts = True .StatusBar = vbNullString End With End Sub Sub ShowSubFolders(ByVal objFolder, bRootFolder As Boolean) Dim colFolders As Object Dim objSubfolder As Object Dim WB As Workbook Dim lnkSources Dim lnk 'strName must be a variant, as ParseName does not work with a string argument Dim strFname Set colFolders = objFolder.SubFolders Application.StatusBar = "Processing " & objFolder.Path If bRootFolder Then Set objSubfolder = objFolder GoTo OneTimeRoot End If For Each objSubfolder In colFolders 'check to see if root directory files are to be processed OneTimeRoot: strFname = Dir(objSubfolder.Path & "\*.xls*") Do While Len(strFname) > 0 Set WB = Workbooks.Open(objSubfolder.Path & "\" & strFname, False) lnkSources = WB.LinkSources If Not IsEmpty(lnkSources) Then For Each lnk In lnkSources lngCnt = lngCnt + 1 If lngCnt Mod 1000 = 0 Then ReDim Preserve StrArray(1 To 4, 1 To (lngCnt + 1000)) StrArray(1, lngCnt) = WB.Path StrArray(2, lngCnt) = WB.Name StrArray(3, lngCnt) = Left$(lnk, InStrRev(lnk, "\")) StrArray(4, lngCnt) = Right$(lnk, Len(lnk) - InStrRev(lnk, "\")) Next End If WB.Close False strFname = Dir Loop If bRootFolder Then bRootFolder = False Exit Sub End If ShowSubFolders objSubfolder, False Next End Sub