使用VBA循环遍历文件夹中的文件？

Question

使用VBA循环遍历文件夹中的文件？我想使用以下方法循环遍历目录的文件VBA在Excel 2010中。在循环中，我需要文件名格式化文件的日期。我已经编写了以下代码，如果文件夹中没有超过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 fileEnd Sub解决问题：下面的解决方案已经解决了我的问题Dir以一种特定的方式(对于15000个文件使用20秒)和使用命令检查时间戳FileDateTime.考虑到另一个答案，从下面的20秒减少到不到1秒。

Answer 1

Dir使用外卡，这样您就可以在添加过滤器的情况下做出很大的改变。test预先准备并避免对每个文件进行测试

Sub LoopThroughFiles()
    Dim StrFile As String
    StrFile = Dir("c:\testfolder\*test*")
    Do While Len(StrFile) > 0
        Debug.Print StrFile
        StrFile = Dir    LoopEnd Sub

Answer 2

迪尔看起来非常快。

Sub LoopThroughFiles()
    Dim MyObj As Object, MySource As Object, file As Variant
   file = Dir("c:\testfolder\")
   While (file <> "")
      If InStr(file, "test") > 0 Then
         MsgBox "found " & file         Exit Sub
      End If
     file = Dir  WendEnd Sub

Answer 3

Dir函数是可行的，但是问题是您不能使用Dir函数递归，如所述在这里，朝向底部.

我处理这个问题的方法是使用Dir函数获取目标文件夹的所有子文件夹，并将它们加载到数组中，然后将数组传递给递归的函数。

这是我写的一个类，它包括搜索过滤器的能力。(你必须原谅匈牙利的符号，这是在它风靡一时的时候写的。)

Private m_asFilters() As StringPrivate m_asFiles As VariantPrivate m_lNext As LongPrivate m_lMax As LongPublic 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 IfEnd FunctionPrivate 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 0Exit SubErrRecursiveAddFiles:End SubPrivate 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 IfEnd FunctionPrivate 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 lEnd Sub