Question

我决定尝试使用UDF来替代Application.FileSearch。我假设一些文件可能位于的位置。互联网上的解决方案倾向于假设用户通常知道文件的位置，这假设它可以在任何地方，

编辑：互联网上的很多解决方案都是长篇大论，我相信它应该更有效率，因此使用这篇文章作为讨论如何实现这一目标的方法

Please note, I have replaced the path directories with an 'X' and the file name is just "File Name"

Public Function FindFile()

If Len(Dir("C:\X\X\X\File Name.xlsm", vbDirectory)) <> 0 Then
    Workbooks.Open ("C:\X\X\X\File Name.xlsm"), UpdateLinks:=False

ElseIf Len(Dir("C:\X\File Name.xlsm", vbDirectory)) <> 0 Then
    Workbooks.Open ("C:\X\File Name.xlsm"), UpdateLinks:=False

ElseIf Len(Dir("C:\X\X\File Name.xlsm", vbDirectory)) <> 0 Then
    Workbooks.Open ("C:\X\X\File Name.xlsm"), UpdateLinks:=False

End If

End Function

我对上面的代码感到满意，但我觉得它可以更加动态到不必指定文件的可能位置。

请随意编辑您认为合适的帖子并提出您的想法：）

Answer 1

你谈论效率，你的意思是可读性吗？还是要求处理能力方面的效率？第一个例子很容易阅读和更改，所以我会说它是可读的，但是如果你知道一个文件在3个位置中的一个位置，那么最好将每个位置分开，就像在第二个例子。

关于以下内容，它依赖于您指定的“HostFolder”中的相关文件，因此有效地越精确，它就越有效。例如，使用以下内容将变得越来越有效：

C：\

C：\报告

C：\报告\月

感谢@Rich的回答：

Loop Through All Subfolders Using VBA

Sub MainBeast()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "C:\mypath\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)

    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        If File.Name = "Name.xlsm" Then
            Workbooks.Open (Folder.Path & "\" & "Name.xlsm"), UpdateLinks:=False
            Workbooks("Name.xlsm").Activate
            Exit Sub
        End If
    Next
End Sub

我应该说，这只会打开它找到名为“name.xlsm”的文件的第一个实例。如果要处理多个文件，则需要进行修改，尽管通过使用Path.FileDateTime存储潜在路径并打开最新文件可以轻松实现这一点。

关于第二个，如果你有一个要检查的地方的候选名单，那么我会使用下面的代码，这更有效，但如果文件不在正确的位置，那么它将无法工作：

sub MainBeast()
    if fileExists("C:\" & "Name.xlsm") then Workbooks.Open ("C:\" & "Name.xlsm"), UpdateLinks:=False
    if fileExists("C:\locA\" & "Name.xlsm") then Workbooks.Open ("C:\locA\" & "Name.xlsm"), UpdateLinks:=False
    if fileExists("C:\locB\" & "Name.xlsm") then Workbooks.Open ("C:\locB\" & "Name.xlsm"), UpdateLinks:=False
End Sub
Function FileExists(ByVal FullPath As String) As Boolean
If dir(FullPath) <> "" Then
    FileExists = True
Else
    FileExists = False
End If
End Function

Answer 2

虽然我很欣赏Excel VBA的文件处理功能，但是人们确实错过了对命令行进行炮轰的技巧，我们可以使用DIR命令行工具打印目录结果然后处理它们。

此外，我们可以异步执行此操作，也就是说我们可以对进程进行shell操作然后执行其他工作（或者只是允许用户进行响应会话），并且当结果准备就绪时我们会处理它们。

DIR命令行工具

DIR命令行工具的键切换是/S，这意味着通过子目录递归处理。有关文档，请参阅dir switches。另外一个关键是将输出传递给文件，以便代码可以处理它。所以命令行（在我的电脑上）看起来像这样

dir k:\testDir\someFile.txt /s > c:\temp\dir.txt

我的k驱动器设置了一些测试数据，临时目录是我们编写结果文件的地方（你的临时目录可能不同）。

但是如果我们在代码中炮制一个进程，那么我们需要一些额外的逻辑;我们需要运行cmd.exe然后将上面的命令行传递给进程。我们可以使用cmd.exe环境变量找到comspec所在的位置。我们还需要将/S /C标记传递给cmd.exe这里是cmd switches的文档

C:\WINDOWS\system32\cmd.exe /S /C dir k:\testDir\someFile.txt /s > c:\temp\dir.txt

所以我们需要运行上面的命令行，我将提出两个实现，一个是同步的，另一个是异步的。

同步实施

密钥代码位于SyncLaunchShelledCmdDir中，它封装了命令行然后调用Windows API获取shelled进程的句柄，然后等待它使用WaitForSingleObject完成，然后我们调用子例程ProcessResultsFile来执行字符串处理和结果解析。

<强> modSyncShellDir.bas

Option Explicit

Private Const msRESULTSFILE As String = "c:\temp\dirSync.txt"
Private Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Const INFINITE = &HFFFF

Private Sub UnitTestSyncLaunchShelledCmdDir()
    SyncLaunchShelledCmdDir "k:\testDir\", "someFile.txt"
End Sub

Private Sub SyncSampleProcessResults(ByVal vResults As Variant)
    '*** YOUR CODE GOES HERE
    Dim vLoop As Variant
    For Each vLoop In vResults
        Debug.Print vLoop
    Next
End Sub

Private Sub SyncLaunchShelledCmdDir(ByVal sTopLevelDirectory As String, ByVal sFileNameToLookFor As String)
    Debug.Assert Right$(sTopLevelDirectory, 1) = "\"


    Dim sCmd As String
    sCmd = VBA.Environ$("comspec") & " /S /C"
    Dim lShelledCmdDir As Long
    lShelledCmdDir = VBA.Shell(sCmd & "  dir " & sTopLevelDirectory & sFileNameToLookFor & " /s > " & msRESULTSFILE)

    Dim hProc As Long
    hProc = OpenProcess(PROCESS_ALL_ACCESS, 0&, lShelledCmdDir)

    If hProc <> 0 Then
        WaitForSingleObject hProc, INFINITE

        Dim sFileContents As String
        sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall

        Dim vResults As Variant
        vResults = ProcessResultsFile(sFileContents, sFileNameToLookFor)
        SyncSampleProcessResults vResults

    End If
    CloseHandle hProc

End Sub

Private Function ProcessResultsFile(ByVal sFileContents As String, ByVal sFileNameToLookFor As String) As Variant

    Dim dic As Object
    Set dic = VBA.CreateObject("Scripting.Dictionary")

    Dim lFindFileName As Long
    lFindFileName = VBA.InStr(1, sFileContents, sFileNameToLookFor, vbTextCompare)

    While lFindFileName > 0
        '* found something so step back and get previous "Directory of"

        Dim lPreviousDirectoryOfPos As Long
        lPreviousDirectoryOfPos = VBA.InStrRev(sFileContents, "Directory of ", lFindFileName + 1, vbTextCompare)

        Dim lDirectoryStringBeginningPos As Long
        lDirectoryStringBeginningPos = lPreviousDirectoryOfPos + Len("Directory of ")

        Dim lNextLineFeedAfterPreviousDirectoryOfPos As Long
        lNextLineFeedAfterPreviousDirectoryOfPos = VBA.InStr(lDirectoryStringBeginningPos, sFileContents, vbNewLine, vbTextCompare)
        If lNextLineFeedAfterPreviousDirectoryOfPos > 0 Then
        Dim sSlice As String
        sSlice = Mid(sFileContents, lDirectoryStringBeginningPos, lNextLineFeedAfterPreviousDirectoryOfPos - lDirectoryStringBeginningPos)


        dic.Add sSlice, 0

        End If

        lFindFileName = VBA.InStr(lFindFileName + 1, sFileContents, sFileNameToLookFor, vbTextCompare)

    Wend

    ProcessResultsFile = dic.keys


End Function

Private Sub UnitTestProcessResultsFile()
    Dim sFileNameToLookFor As String
    sFileNameToLookFor = "someFile.txt"

    Dim sFileContents As String
    sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall
    Dim vResults As Variant
    vResults = ProcessResultsFile(sFileContents, sFileNameToLookFor)

End Sub

<强> modAsyncShellDir.bas
这个实现是异步的，我们尽可能多地重用代码但是为了使这个工作我们需要给自己一些模块级变量，我们还需要使用Application.OnTime和Application.Run来处理轮询和回调。这次我们不会等待流程完成，而是使用Windows API调用GetExitCodeProcess

轮询其退出代码

Option Explicit

Private mlShelledCmdDir As Double
Private msFileNameToLookFor As String
Private msCallbackFunction As String

Private Const msRESULTSFILE As String = "c:\temp\dirAsync.txt"
Private Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal lnghProcess As Long, lpExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Sub UnitTestAsyncLaunchShelledCmdDir()
    AsyncLaunchShelledCmdDir "k:\testDir\", "someFile.txt", "AsyncSampleProcessResults"
End Sub


Private Sub AsyncSampleProcessResults(ByVal vResults As Variant)
    '*** YOUR CODE GOES HERE
    Dim vLoop As Variant
    For Each vLoop In vResults
        Debug.Print vLoop
    Next
End Sub

Private Sub AsyncLaunchShelledCmdDir(ByVal sTopLevelDirectory As String, ByVal sFileNameToLookFor As String, ByVal sCallbackFunction As String)
    Debug.Assert Right$(sTopLevelDirectory, 1) = "\"
    msFileNameToLookFor = sFileNameToLookFor
    msCallbackFunction = sCallbackFunction
    Dim sCmd As String
    sCmd = VBA.Environ$("comspec") & " /S /C"
    mlShelledCmdDir = VBA.Shell(sCmd & "  dir " & sTopLevelDirectory & sFileNameToLookFor & " /s > " & msRESULTSFILE)


    Application.OnTime Now() + CDate("00:00:01"), "PollLaunchShelledCmdDir"
End Sub

Private Sub PollLaunchShelledCmdDir()
    If Not IsLaunchShelledCmdDirRunning Then
        Dim sFileContents As String
        sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall

        Dim vResults As Variant
        vResults = ProcessResultsFile(sFileContents, msFileNameToLookFor)
        Application.Run msCallbackFunction, vResults
    Else
        Application.OnTime Now() + CDate("00:00:01"), "PollLaunchShelledCmdDir"
    End If
End Sub


Private Function IsLaunchShelledCmdDirRunning() As Boolean
    Dim hProc As Long
    Dim lExitCode As Long
    Dim lRet As Long

    hProc = OpenProcess(PROCESS_ALL_ACCESS, 0&, mlShelledCmdDir)
    If hProc <> 0 Then
        GetExitCodeProcess hProc, lExitCode
        IsLaunchShelledCmdDirRunning = (lExitCode <> 0)
    End If
    CloseHandle hProc

End Function




Private Function ProcessResultsFile(ByVal sFileContents As String, ByVal sFileNameToLookFor As String) As Variant

    Dim dic As Object
    Set dic = VBA.CreateObject("Scripting.Dictionary")

    Dim lFindFileName As Long
    lFindFileName = VBA.InStr(1, sFileContents, sFileNameToLookFor, vbTextCompare)

    While lFindFileName > 0
        '* found something so step back and get previous "Directory of"

        Dim lPreviousDirectoryOfPos As Long
        lPreviousDirectoryOfPos = VBA.InStrRev(sFileContents, "Directory of ", lFindFileName + 1, vbTextCompare)

        Dim lDirectoryStringBeginningPos As Long
        lDirectoryStringBeginningPos = lPreviousDirectoryOfPos + Len("Directory of ")

        Dim lNextLineFeedAfterPreviousDirectoryOfPos As Long
        lNextLineFeedAfterPreviousDirectoryOfPos = VBA.InStr(lDirectoryStringBeginningPos, sFileContents, vbNewLine, vbTextCompare)
        If lNextLineFeedAfterPreviousDirectoryOfPos > 0 Then
            Dim sSlice As String
            sSlice = Mid(sFileContents, lDirectoryStringBeginningPos, lNextLineFeedAfterPreviousDirectoryOfPos - lDirectoryStringBeginningPos)


            dic.Add sSlice, 0

        End If

        lFindFileName = VBA.InStr(lFindFileName + 1, sFileContents, sFileNameToLookFor, vbTextCompare)

    Wend

    ProcessResultsFile = dic.keys
End Function


Private Sub UnitTestProcessResultsFile()
    Dim sFileNameToLookFor As String
    sFileNameToLookFor = "someFile.txt"

    Dim sFileContents As String
    sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall
    Dim vResults As Variant
    vResults = ProcessResultsFile(sFileContents, sFileNameToLookFor)

End Sub

我希望这些不是太冗长。我认为很好地支持并获得另一个进程来完成一些工作，特别是如果可以异步执行此操作。这是一种非常有用的技术，可以使Excel VBA应用程序响应迅速。对于诸如光盘活动这样众所周知的漫长过程尤其如此。

感谢您设置赏金！

Answer 3

选项1 - RecentFiles

虽然我不得不同意@ TimWilliams＆＃39;评估＆＃34;啰嗦＆＃34;并不意味着低效率＃34;如果文件被频繁访问，你应该能够在.RecentFiles集合中找到它：

Public Function FindFile() As String
    Dim x As Variant
    For Each x In Application.RecentFiles
        If x.Name Like "*File Name.xlsm" Then
            FindFile = x.Name
            Exit Function
        End If
    Next x
End Function

请注意，这是一个 完整的 黑客解决方案，我绝不会将其用于任何类似于生产代码的内容，因为如果失败将采用后备方法类似于你发布的内容或@ tompreston的答案。

选项2 - WMI

同样，这归结为您对＆＃34;高效＆＃34;的定义。是。您可以使用WMI查询文件系统，但这很可能 骇人地 处理时间变慢，特别是如果您没有索引所有内容：

Public Function FindFile() As String
    With CreateObject("winmgmts:root/CIMV2")
        Dim results As Object, result As Object, query As String
        query = "SELECT TOP 1 * FROM Cim_DataFile WHERE Filename = 'File Name' AND Extension = 'xlsm'"
        Set results = .ExecQuery(query)
        For Each result In results
            FindFile = result.Path & "File Name.xlsm"
            Exit Function
        Next
    End With
End Function

你可以通过＆＃34;建议＆＃34;来加快速度。添加了"AND Path IN ('C:\X\X\', 'C:\X\X\X\')"行查询过滤器的目录，但此时您最好使用问题中的原始解决方案。

正确的 答案将倾向于长期啰嗦＆＃34;，因为这可以避免让沮丧的最终用户在他们变得奇怪时不断与您联系错误对话框，因为您选择了简洁的代码而不是健壮的代码。＆＃34;效率＆＃34;并不仅仅是衡量你必须输入的数量。我考虑一个解决方案，我从来没有提供支持或维持 令人难以置信的 高效。

Answer 4

全部，下面介绍的解决方案是根据 Tom Prestons 回答构建的。我给了应得的信用。

代码的关键部分：

添加了一项检查，以查看是否已启用对Microsoft Scripting Run Time的引用。在运行需要脚本的代码时，这一点至关重要。此代码将在主机计算机上运行，并且它们通常不会启用任何引用，因此代码将失败。 N.B归功于Is there a code to turn on Microsoft Scripting Runtime Library? @Vasily。代码被修改为＆＃34; AddFromFile＆＃34;与GUID相反。 但是，假设所有主机都将在同一位置包含scrun dll

HostFolder非常高级。从那里，必须搜索相当数量的子文件夹，但不幸的是我需要在这个级别。对于阅读此内容的任何人，如果您100％确定客户不会将密钥文件移至HostFolder的外部位置，请使其更加具体，以加快运行时间
通过＆＃34;应用程序优化代码。＆＃34; （公平地说，由于某些原因它没有什么区别，没有它需要40秒，而且需要c32秒）
使用File.Name替换Workbooks.Open命令，而不是实际引用文件名
全局声明的所有变量（更清洁）

<强> CODE：

Option Explicit
Dim FileSystem As Object
Dim HostFolder As String
Dim Ref As Object, CheckRefEnabled%
Sub FindFile()
HostFolder = "F:\x\x\"

CheckRefEnabled = 0
With ThisWorkbook
    For Each Ref In .VBProject.References
        If Ref.Name = "Scripting" Then
            CheckRefEnabled = 1
            Exit For
        End If
    Next Ref
    If CheckRefEnabled = 0 Then
        .VBProject.References.AddFromFile ("C:\Windows\System32\scrrun.dll")
    End If
End With

Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)

End Sub
Sub DoFolder(Folder)

With Application
    .EnableEvents = False
    .DisplayStatusBar = False
    .DisplayAlerts = False
    .ScreenUpdating = False
End With

    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        If File.Name = "y.xlsm" Then
            Workbooks.Open (Folder.path & "\" & File.Name), UpdateLinks:=False
            Workbooks(File.Name).Activate
            Exit Sub
        End If
    Next

With Application
    .EnableEvents = True
    .DisplayStatusBar = True
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub

感谢大家的贡献，Stack Overflow社区非常棒！

如何改进我的功能来处理Application.FileSearch VBA的替代方案

4 个答案:

选项1 - RecentFiles

选项2 - WMI