我怎样才能改善我的处理替代Application.FileSearch VBA的function
我已经决定尝试UDF替代Application.FileSearch。 我假设一些文件可能位于的位置。 互联网上的解决scheme倾向于假定用户通常知道文件所在的位置，假设它可以在任何地方，
编辑：在互联网上的解决scheme很多是啰嗦，我相信它应该是更有效率，因此使用这个post作为一个讨论的手段，以便如何可以实现
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
我对上面的代码感到满意，但是我觉得可以更加dynamic地指定一个文件的POSSIBLE位置。
请随意编辑这篇文章，因为你认为合适，并贡献你的想法:)
你谈效率，你的意思是可读性？ 还是需要处理能力方面的效率？ 第一个例子很容易阅读和修改，所以我会说它是可读的，但是如果你知道一个文件位于3个位置之一中，最好是单独指定每个位置，就像在第二个例子。
关于下面的内容，它依赖于你指定的“HostFolder”内的文件，所以你可以做得越精确，效率就越高。 例如，使用以下将会越来越高效：
C：\
C：\报告
C：\报告\五月
感谢@Rich在这里的回答：
使用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
我应该说，这只是打开它find名为“name.xlsm”的文件的第一个实例。 如果要处理多个文件，则需要进行修改，但通过使用Path.FileDateTime存储潜在的path并打开最近的文件，这应该很容易实现。
关于第二个，如果你有一个候选地点的候选名单，那么我会使用下面的代码，这是更有效的，但如果该文件不在正确的位置，那么它将无法正常工作：
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
虽然我很欣赏Excel VBA的文件处理function，但是我们不会错过在命令行中进行脱壳的技巧，我们可以使用DIR命令行工具来打印目录结果，然后处理这些结果。
进一步，我们可以asynchronous做到这一点，也就是说，我们可以将stream程放在一边，然后离开并做其他工作（或者让用户有一个响应会话），当结果准备就绪时，我们会处理它们。
DIR命令行工具
到DIR命令行工具的键切换是/S ，这意味着通过子目录recursion地进行处理。 请参阅dir开关以获取文档。 另外，将输出pipe道输出到文件是非常重要的，这样可以通过代码进行处理。 所以命令行（在我的电脑上）看起来像这样
dir k:\testDir\someFile.txt /s > c:\temp\dir.txt
我的K驱动器设置了一些testing数据，临时目录是我们写结果文件的地方（你的临时目录可能不同）。
但是如果我们在代码中炮制一个进程，那么我们需要一些额外的逻辑; 我们需要运行cmd.exe ，然后通过上面的命令行来处理。 通过使用comspec环境variables，我们可以findcmd.exe所在的comspec 。 我们还需要将/S /C标志传递给cmd.exe这里是该cmd开关的文档
C:\WINDOWS\system32\cmd.exe /S /C dir k:\testDir\someFile.txt /s > c:\temp\dir.txt
所以我们需要运行上面的命令行，我将介绍两个实现，一个是同步的，另一个是asynchronous的。
同步实现
关键代码位于SyncLaunchShelledCmdDir中，该命令行将shell命令行调用，然后调用Windows API作为带壳进程的句柄，然后等待WaitForSingleObject完成，然后调用子程序ProcessResultsFile执行string处理和结果分析。
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
这个实现是asynchronous的，我们尽可能多的重复使用代码，但为了使这个工作我们需要给自己一些模块级别的variables，我们还需要使用Application.OnTime和Application.Run来处理轮询和callback。 这次我们不等待进程完成，而是使用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
我希望这些不是太啰嗦。 我认为很好的做法是让别人去做一些工作，特别是如果可以asynchronous做到的话。 这是一个非常有用的技术，可以使Excel VBA应用程序响应得非常快。 对于光盘活动等冗长的stream程尤其如此。
感谢设置赏金！
选项1 – RecentFiles
虽然我不得不同意@TimWilliams的评价，“啰嗦”并不意味着“低效率”，如果文件被频繁访问，你应该能够在.RecentFiles集合中find它：
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
请记住，这是一个完整的黑客解决scheme，我绝不会将它用于类似于生产代码的任何事情，因为如果失败的方法与后面的方法类似，可能与您发布或@ 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
你也许可以通过沿"AND Path IN ('C:\X\X\', 'C:\X\X\X\')"这一行的“build议”目录添加一个查询filter来加快速度。在这一点上，你最好用你的原始解决scheme。
正确的答案是趋向于“冗长的啰嗦”，因为这样可以避免最终用户在遇到奇怪的错误对话时经常与您联系，因为您select了简洁的编码而不是强大的代码。 “效率”并不是衡量你需要input多less。 我会考虑一个解决scheme，我永远不必提供支持或保持令人难以置信的高效率。
所有，下面介绍的解决scheme是由Tom Prestons的答案。 我已经在应得的学分。
代码的关键部分：
-
检查已添加，以查看是否已启用Microsoft脚本运行时引用。 运行需要脚本的代码时，这是非常重要的。 这段代码将在主机上运行，而且更常见的情况是没有启用引用，代码将失败。 注意： 是否有代码打开Microsoft Scripting Runtime Library？ @Vasily。 代码被修改为“AddFromFile”与GUID相反。 然而，这假设所有的主机将包含scrunn DLL在相同的位置
- HostFolder是非常高的水平。 从那里，相当数量的子文件夹必须通过search，但不幸的是我需要在这个级别。 对于任何读这个文件的人来说，如果你100％肯定地知道客户端不会把密钥文件移动到HostFolder的一个位置，那么加快运行时间
- 通过“应用程序”进行代码优化 （公平地说，由于某种原因，它没有什么区别，没有40秒的时间，而且需要32秒）
- 使用File.NamereplaceWorkbooks.Open命令，而不是实际引用文件的名称
- 所有variables全局声明（更干净）
码：
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社区非常好！