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

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

编辑：互联网上的许多解决方案都是冗长的，我相信它应该更有效，因此使用这篇文章作为讨论如何实现这一点的手段

请注意，我已将路径目录替换为“X”，文件名仅为“file name”

公共函数FindFile（）
如果Len（Dir（“C:\X\X\X\File Name.xlsm”，vbDirectory））为0，则
Workbooks.Open（“C:\X\X\X\File Name.xlsm”），UpdateLinks:=False
ElseIf Len（Dir（“C:\X\File Name.xlsm”，vbDirectory））0然后
Workbooks.Open（“C:\X\File Name.xlsm”），UpdateLinks:=False
ElseIf Len（Dir（“C:\X\X\File Name.xlsm”，vbDirectory））0然后
Workbooks.Open（“C:\X\X\File Name.xlsm”），UpdateLinks:=False
如果结束
端函数

我对上面的代码很满意，但我觉得它可能更具动态性，甚至不必指定文件的可能位置

---

请随意编辑这篇你认为合适的文章，并提出你的想法：）

你说的是效率，你是说可读性吗？或在所需处理能力方面的效率？第一个示例很容易读取和更改，因此我认为它是可读的，但是如果您知道一个文件位于（比如）3个位置中的一个位置，则最好分别对每个位置进行dir，如第二个示例所示

关于以下内容，它依赖于所讨论的文件位于您指定的“HostFolder”中，因此您越精确，它的效率就越高。例如，使用以下工具将越来越有效：

C:\

C:\报告

C:\Reports\May

感谢@Rich在这里的回答：

我应该说，这将只打开它找到的名为“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

sub mainbast（）
如果文件存在（“C:\”&“Name.xlsm”），则Workbooks.Open（“C:\”&“Name.xlsm”），UpdateLink:=False
如果文件存在（“C:\locA\”和“Name.xlsm”），则Workbooks.Open（“C:\locA\”和“Name.xlsm”），UpdateLink:=False
如果文件存在（“C:\locB\”和“Name.xlsm”），则Workbooks.Open（“C:\locB\”和“Name.xlsm”），UpdateLink:=False
端接头
函数FileExists（ByVal FullPath为字符串）为布尔值
如果目录（完整路径）“，则
FileExists=True
其他的
FileExists=False
如果结束
端函数

选项1-接收文件 尽管我必须同意@TimWilliams的评估，即“冗长”并不意味着“低效”，但如果文件访问频率足够高，您应该能够在

。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 同样，这可以归结为你对“效率”的定义。您可以使用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

您可能可以通过在（'C:\X\X\'，'C:\X\X\X\'）“”中添加查询过滤器来“建议”目录，从而加快速度，但此时您最好使用问题的原始解决方案

---

---

正确的答案将倾向于“冗长”，因为这样可以避免沮丧的最终用户在收到奇怪的错误对话框时不断联系您，因为您选择了简洁的编码而不是健壮的代码。“效率”并不仅仅是衡量你必须打字多少的标准。我会考虑一个解决方案，我不需要提供支持或维护<强>难以置信的<强> > .< /p> ，虽然我很欣赏Excel VBA的文件处理能力，但是我们没有注意到命令行去壳的技巧，我们可以使用<代码> dir < /Cord>命令行工具来打印目录结果，然后处理这些结果。p> 此外，我们还可以异步完成这项工作，也就是说，我们可以对流程进行shell处理，然后进行其他工作（或者只允许用户进行响应会话），当结果就绪时，我们将对其进行处理

DIR命令行工具

切换到

DIR

命令行工具的键是

/S

，这意味着通过子目录递归处理。有关文档，请参阅。 此外，将输出通过管道传输到文件，以便代码可以处理它，这一点也很重要。因此（在我的计算机上）命令行如下所示

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

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

但是如果我们在代码中炮轰一个进程，那么我们需要一些额外的逻辑；我们需要运行

cmd.exe

，然后将其传递到上面的命令行进行处理。通过使用

comspec

环境变量，我们可以找到

cmd.exe

的位置。我们还需要将

/S/C

标志传递给

cmd.exe

，这是相关的文档

C:\WINDOWS\system32\cmd.exe/S/C dir k:\testDir\someFile.tx
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

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

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

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

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