【发布时间】：2015-05-28 15:41:49
【问题描述】：
我正在寻找使用 Excel 宏递归搜索子目录以查找文件模式的最快执行方法。 Excel VBA 在这方面似乎相当缓慢。
到目前为止我尝试过的事情（一些基于其他 stackoverflow 建议）：
- 专门使用 Dir 递归遍历子目录并在每个文件夹中搜索文件模式。 （最慢）
- 使用 Folder.Files 集合遍历 FileSystemObject 文件夹，根据文件模式检查每个文件。 （更好，但仍然很慢）
- 遍历 FileSystemObject 文件夹，然后使用 Dir 检查每个文件夹的文件模式（目前最快，但每个文件仍需要几秒钟，如果可能，我想优化）
我查看了 My.Computer.FileSystem.GetFiles，它看起来很完美（允许您指定通配符模式并使用单个命令搜索子文件夹） - 但 Excel 似乎不支持它据我所知，VBA 仅在 VB 中。
我目前正在使用下面的 FindFile Sub，它是迄今为止性能最好的。如果有人对如何进一步改进这一点有任何建议，我将非常感激！
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Function Recurse(sPath As String, targetName As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
On Error Resume Next
Set myFolder = FSO.GetFolder(sPath)
If Err.Number <> 0 Then
MsgBox "Error accessing " & sPath & ". The macro will abort."
Err.Clear
Exit Function
End If
On Error GoTo 0
Dim foundFolderPath As String
Dim foundFileName As String
foundFolderPath = ""
foundFileName = ""
For Each mySubFolder In myFolder.SubFolders
foundFileName = Dir(mySubFolder.Path & "\" & targetName & "*")
If foundFileName <> vbNullString Then
foundFolderPath = mySubFolder.Path & "\" & foundFileName
End If
If foundFolderPath <> vbNullString Then
Recurse = foundFolderPath
Exit Function
End If
foundFolderPath = Recurse(mySubFolder.Path, targetName)
If foundFolderPath <> vbNullString Then
Recurse = foundFolderPath
Exit Function
End If
Next
End Function
Sub FindFile()
Dim start As Long
start = GetTickCount()
Dim targetName As String
Dim targetPath As String
targetName = Range("A1").Value 'Target file name without extension
targetPath = "C:\Example\" & Range("B1").Value 'Subfolder name
Dim target As String
target = Recurse(targetPath, targetName)
Dim finish As Long
finish = GetTickCount()
MsgBox "found: " & target & vbNewLine & vbNewLine & (finish - start) & " milliseconds"
End Sub
根据接受的答案更新文件搜索功能
这个版本的 FindFile() 的执行速度大约是我最初粘贴在上述问题中的方法的两倍。正如以下帖子中所讨论的，这应该适用于 32 位或 64 位版本的 Excel 2010 及更高版本。
Option Explicit
Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As Long
Private Declare PtrSafe Function FindFirstFileW Lib "kernel32" (ByVal lpFileName As LongPtr, ByVal lpFindFileData As LongPtr) As LongPtr
Private Declare PtrSafe Function FindNextFileW Lib "kernel32" (ByVal hFindFile As LongPtr, ByVal lpFindFileData As LongPtr) As LongPtr
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Const MAX_PATH As Long = 260
Const ALTERNATE As Long = 14
' Can be used with either W or A functions
' Pass VarPtr(wfd) to W or simply wfd to A
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * ALTERNATE
End Type
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = 16 '0x10
Private Const INVALID_HANDLE_VALUE As LongPtr = -1
Function Recurse(folderPath As String, fileName As String)
Dim fileHandle As LongPtr
Dim searchPattern As String
Dim foundPath As String
Dim foundItem As String
Dim fileData As WIN32_FIND_DATA
searchPattern = folderPath & "\*"
foundPath = vbNullString
fileHandle = FindFirstFileW(StrPtr(searchPattern), VarPtr(fileData))
If fileHandle <> INVALID_HANDLE_VALUE Then
Do
foundItem = Left$(fileData.cFileName, InStr(fileData.cFileName, vbNullChar) - 1)
If foundItem = "." Or foundItem = ".." Then 'Skip metadirectories
'Found Directory
ElseIf fileData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY Then
foundPath = Recurse(folderPath & "\" & foundItem, fileName)
'Found File
'ElseIf StrComp(foundItem, fileName, vbTextCompare) = 0 Then 'these seem about equal
ElseIf InStr(1, foundItem, fileName, vbTextCompare) > 0 Then 'for performance
foundPath = folderPath & "\" & foundItem
End If
If foundPath <> vbNullString Then
Recurse = foundPath
Exit Function
End If
Loop While FindNextFileW(fileHandle, VarPtr(fileData))
End If
'No Match Found
Recurse = vbNullString
End Function
Sub FindFile()
Dim targetName As String
Dim targetPath As String
targetName = Range("A4").Value
targetPath = "C:\Example\" & Range("B4").Value
Dim target As String
target = Recurse(targetPath, targetName)
MsgBox "found: " & target
End Sub
【问题讨论】：
-
您已经在使用来自
kernel32的函数来为您的日常工作计时，我建议您在某个地方有更快的方法来搜索驱动器。我不确定你需要什么函数调用，但我认为通过 Win API 看一下就可以了。 -
如果这部分的速度很关键，你能把它移到 Excel 之外吗？不确定速度，但这是related post on that front。
-
+1 表示问题。不确定这是否很快，但你看过FindFirstFile 和FindNextFile 吗？有一个例子here。 API 调用应该会影响性能，但总体而言它们可能会更快。
-
为了将来参考，如果您发布有关 64 位版本 Excel 的问题，您应该指定。出于兼容性原因，Microsoft 建议使用 32 位版本。如果您没有使用推荐的兼容版本，您想告诉人们，以便他们可以为您提供适当的帮助。
-
我发现使用 windows shell 比原生 VBA 或 FileSystemObject 方法快得多。
标签： performance vba excel