搜索驱动器的excel依赖关系 [英] Search drive for excel dependencies

问题描述

我目前正在简化公司的文件结构。这是一个完整的混乱
目前，我正在做财务部门，其中分配了excel文件之间的依赖关系。这些文件我不能迁移到新的结构，因为位置的更改和依赖关系丢失。

因此，我正在搜索一个工具来扫描一个文件夹及其子-folders为excel依赖。我想列出这些，并说：嘿，这些文件呢？

任何想法？

解决方案

下面的代码

• 打开位于 strStartFolder （即C：\temp）在本例中使用递归目录


• 查找每个文件中的任何文件链接


• 使用数组来保存，然后填充最终结果

请在 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 strS tartFolder As String 
 
'为用户设置应用程序
应用程序
 .ScreenUpdating = False 
 .DisplayAlerts = False 
结束
 
'重置公共变量
 lngCnt = 0 
 ReDim StrArray（1到4，1到1000）
 
 strStartFolder =c：\temp
设置objFSO = CreateObject（Scripting.FileSystemObject）
 
'格式输出表
设置WB = Workbooks.Add（1）
设置ws = WB.Worksheets（1）
 ws。[a1] = Now（）
 ws。[a2] = strStartFolder 
 ws。[a1：a3] .Horizo​​ntalAlignment = xlLeft 
 
 ws。[A4 ：D4] .Value = Array（Folder，File，Linked File，Linked File Path）
 ws.Range（[a1]，[c4]）。Font.Bold = True 
 ws.Rows（5）。选择
 ActiveWindow.FreezePanes = True 
 
 
设置objFSO = CreateObject（Scripting.FileSystemObject）
设置objFolder = objFSO.GetFolder（strStartFolder）
 
'启动代码来收集文件
 ShowSubFolders objFolder，True 
 ShowSubFolders objFolder，False 
 
如果lngCnt> 0然后
'完成输出
使用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 
 MsgBoxNo files found！，vbCritical 
 WB.Close False 
 End If 
 
'tidy up 
 
设置objFSO =没有
 
应用程序
 .ScreenUpdating = True 
 .DisplayAlerts = True 
 .StatusBar = vbNullString 
 End with 
 End Sub 
 
 
 Sub ShowSubFolders（ByVal objFolder，bRootFolder As Boolean）
 
 Dim colFolders作为对象
 Dim objSubfolder As Object 
 Dim WB As Workbook 
 Dim lnkSources 
 Dim lnk 
 
'strName必须是一个变体，因为ParseName不起作用用一个字符串参数
 Dim strFname 
 Set colFolders = objFolder.SubFolders 
 Application.St atusBar =处理& objFolder.Path 
 
如果bRootFolder然后
设置objSubfolder = objFolder 
 GoTo OneTimeRoot 
结束如果
 
对于每个objSubfolder在colFolders 
检查根目录文件是否被处理
 OneTimeRoot：
 strFname = Dir（objSubfolder.Path&\ * .xls *）
 Do While Len（strFname ）> 0 
设置WB = Workbooks.Open（objSubfolder.Path&\& strFname，False）
 lnkSources = WB.LinkSources 
如果不是IsEmpty（lnkSources）然后
对于每个lnk在lnkSources 
 lngCnt = lngCnt + 1 
如果lngCnt Mod 1000 = 0然后ReDim保留StrArray（1到4，1到（lngCnt + 1000））
 StrArray（1， lngCnt）= WB.Path 
 StrArray（2，lngCnt）= WB.Name 
 StrArray（3，lngCnt）= Left $（lnk，InStrRev（lnk，\））
 StrArray（4，lngCnt）=右$（lnk，Len（lnk） -  InStrRev（lnk，\））
下一个
 
如果
 WB.Close False 
 strFname = Dir 
循环
如果bRootFolder然后
 bRootFolder = False 
退出Sub 
结束If 
 ShowSubFolders objSubfolder，False 
 Next 
 End Sub 
  

I am currently simplifying a file structure of a company. It is a total mess. Currently I am doing the finance department, which has allot of dependencies between excel files. These files I cannot migrate to the new structure, because the location changes and the dependencies is lost.

Therefore I am in search of a tool to scan a folder and its sub-folders for excel dependencies. I want to list these and say: hey guys, what about these files?

Any ideas?

解决方案

The code below

• opens each file that sits in or below the directory specified by strStartFolder (ie "C:\temp") in this example using a recursive Dir
• looks for any file links in each file
• uses an array to hold then populate the final results

Pls change your path in strStartFolder to suit

This code was formerly published as an article on another forum

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

这篇关于搜索驱动器的excel依赖关系的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！