excel - 搜索 excel 依赖项的驱动器

Question

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

因此，我正在寻找一种工具来扫描文件夹及其子文件夹以查找 excel 依赖项。我想列出这些并说：嘿，伙计们，这些文件呢？

有任何想法吗？

Answer 1

下面的代码

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

请改变你的路径strStartFolder以适应

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

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