为了账号安全,请及时绑定邮箱和手机立即绑定

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

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

潇湘沐 2019-05-30 10:15:22
使用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秒。
查看完整描述

4 回答

?
天涯尽头无女友

TA贡献1831条经验 获得超9个赞

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


查看完整回答
反对 回复 2019-05-30
?
湖上湖

TA贡献2003条经验 获得超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


查看完整回答
反对 回复 2019-05-30
?
慕容708150

TA贡献1831条经验 获得超4个赞

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


查看完整回答
反对 回复 2019-05-30
  • 4 回答
  • 0 关注
  • 3555 浏览
慕课专栏
更多

添加回答

举报

0/150
提交
取消
意见反馈 帮助中心 APP下载
官方微信