我想使用 Excel 2010 中的 vba 循环遍历目录的文件。在循环中,我需要:文件名和文件格式化的日期。我已编写了以下代码...
Excel 2010 中的 vba 循环遍历目录的文件
在循环中,我需要:
我编写了以下代码,如果文件夹中的文件不超过 50 个,则运行良好,否则速度会非常慢(我需要它处理包含超过 10000 个文件的文件夹)。此代码的唯一问题是查找操作 file.name
需要花费大量时间。
代码可以运行但是速度太慢了(每 100 个文件需要 15 秒):
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
Set MySource = MyObj.GetFolder("c:\testfolder\")
For Each file In MySource.Files
If InStr(file.name, "test") > 0 Then
MsgBox "found"
Exit Sub
End If
Next file
End Sub
问题解决:
Dir
特定方式(15000 个文件需要 20 秒)并使用命令检查时间戳 FileDateTime
.
Dir 函数是可行的方法,但 the problem is that you cannot use the Dir
function recursively ,如此处所述 ,在底部 .
我处理这个问题的方法是使用函数 Dir
获取目标文件夹的所有子文件夹并将它们加载到数组中,然后将数组传递到递归函数中。
这是我编写的一个可以实现此功能的一个类,它包括搜索过滤器的功能。( 您必须原谅匈牙利表示法,因为它是在匈牙利表示法风靡一时时编写的。) )
Private m_asFilters() As String
Private m_asFiles As Variant
Private m_lNext As Long
Private m_lMax As Long
Public Function GetFileList(ByVal ParentDir As String, Optional ByVal sSearch As String, Optional ByVal Deep As Boolean = True) As Variant
m_lNext = 0
m_lMax = 0
ReDim m_asFiles(0)
If Len(sSearch) Then
m_asFilters() = Split(sSearch, "|")
Else
ReDim m_asFilters(0)
End If
If Deep Then
Call RecursiveAddFiles(ParentDir)
Else
Call AddFiles(ParentDir)
End If
If m_lNext Then
ReDim Preserve m_asFiles(m_lNext - 1)
GetFileList = m_asFiles
End If
End Function
Private Sub RecursiveAddFiles(ByVal ParentDir As String)
Dim asDirs() As String
Dim l As Long
On Error GoTo ErrRecursiveAddFiles
'Add the files in 'this' directory!
Call AddFiles(ParentDir)
ReDim asDirs(-1 To -1)
asDirs = GetDirList(ParentDir)
For l = 0 To UBound(asDirs)
Call RecursiveAddFiles(asDirs(l))
Next l
On Error GoTo 0
Exit Sub
ErrRecursiveAddFiles:
End Sub
Private Function GetDirList(ByVal ParentDir As String) As String()
Dim sDir As String
Dim asRet() As String
Dim l As Long
Dim lMax As Long
If Right(ParentDir, 1) <> "\" Then
ParentDir = ParentDir & "\"
End If
sDir = Dir(ParentDir, vbDirectory Or vbHidden Or vbSystem)
Do While Len(sDir)
If GetAttr(ParentDir & sDir) And vbDirectory Then
If Not (sDir = "." Or sDir = "..") Then
If l >= lMax Then
lMax = lMax + 10
ReDim Preserve asRet(lMax)
End If
asRet(l) = ParentDir & sDir
l = l + 1
End If
End If
sDir = Dir
Loop
If l Then
ReDim Preserve asRet(l - 1)
GetDirList = asRet()
End If
End Function
Private Sub AddFiles(ByVal ParentDir As String)
Dim sFile As String
Dim l As Long
If Right(ParentDir, 1) <> "\" Then
ParentDir = ParentDir & "\"
End If
For l = 0 To UBound(m_asFilters)
sFile = Dir(ParentDir & "\" & m_asFilters(l), vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem)
Do While Len(sFile)
If Not (sFile = "." Or sFile = "..") Then
If m_lNext >= m_lMax Then
m_lMax = m_lMax + 100
ReDim Preserve m_asFiles(m_lMax)
End If
m_asFiles(m_lNext) = ParentDir & sFile
m_lNext = m_lNext + 1
End If
sFile = Dir
Loop
Next l
End Sub