使用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

问题解决：

我的问题已通过以下解决方案解决，以特定方式使用（20 个文件为 15000 秒）并使用命令检查时间戳。DirFileDateTime
考虑到下面的另一个答案，20 秒减少到不到 1 秒。

VBA Excel

0赞 Michiel van der Blonk 11/23/2015

对于VBA来说，您的初始时间似乎仍然很慢。您是否正在使用 Application.ScreenUpdating=false？

3赞 baldmosher 1/25/2017

你似乎错过了 Set MyObj = New FileSystemObjectcode

19赞 Mathieu Guindon 8/9/2017

我发现人们很快将 FSO 称为“慢”，但没有人提到通过简单地使用早期绑定而不是后期绑定调用可以避免的性能损失。Object

答：

168赞 grantnz 4/30/2012 #1

Dir 似乎非常快。

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
  Wend
End Sub

4赞 tyrex 4/30/2012

太好了，非常感谢。我确实使用 Dir，但我不知道您也可以以这种方式使用它。此外，使用该命令，我的问题也解决了。FileDateTime

5赞 tyrex 4/30/2012

还有一个问题。如果 DIR 从最近的文件开始循环，我可以大大提高速度。你看到有什么方法可以做到这一点吗？

4赞 tyrex 4/30/2012

我的后一个问题已通过以下 brettdj 的评论得到解决。

0赞 AnalystCave.com 1/25/2016

然而，Dir 会.如果需要：analystcave.com/vba-dir-function-how-to-traverse-directories/...nottraverse the whole directory tree

0赞 baldmosher 1/25/2017

Dir 也会被其他 Dir 命令打断，因此如果您运行包含 Dir 的子例程，它可以在原始 Sub 中“重置”它。按照原始问题使用 FSO 可以消除此问题。编辑：刚刚看到下面@LimaNightHawk的帖子，同样的事情

297赞 brettdj 4/30/2012 #2

Dir需要通配符，这样您就可以做出很大的不同，添加过滤器以预先处理并避免测试每个文件test

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

33赞 tyrex 4/30/2012

伟大。这只是将运行时间从 20 秒提高到 <1 秒。这是一个很大的改进，因为代码将经常运行。谢谢！！

7赞 brettdj 5/26/2016

我不认为这个改进水平（20 - xxx 倍）——我认为这是通配符有所作为。

1赞 hamish 11/20/2018

DIR（）似乎没有返回隐藏文件。

2赞 Vincent 4/14/2020

@hamish，您可以更改其参数以返回不同类型的文件（隐藏、系统等） - 请参阅 MS 文档：learn.microsoft.com/en-us/office/vba/language/reference/...

2赞 Kar.ma 6/23/2020

我不明白这条线.这对我不起作用。我用了。StrFile = DirOutput = StrFile

29赞 LimaNightHawk 6/3/2014 #3

Dir 函数是要走的路，但问题是你不能递归地使用 Dir 函数，如此处所述，在底部。

我处理这个问题的方法是使用该函数获取目标文件夹的所有子文件夹并将它们加载到数组中，然后将数组传递到递归函数中。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

0赞 jechaviz 7/26/2014

如果我想列出在列中找到的文件，那么这个实现可能是什么？

0赞 LimaNightHawk 7/28/2014

@jechaviz GetFileList 方法返回 String 数组。您可能只是遍历数组并将项添加到 ListView 或类似的东西。有关如何在列表视图中显示项目的详细信息可能超出了本文的范围。

0赞 robertocm 9/28/2022

非常感谢，只是建议在函数的末尾，可以添加一个 Else：......正如这里所建议的：[stackoverflow.com/a/35221544/6406135]GetFileListIf m_lNext ThenElseReDim GetFileList(0) As String

62赞 benmichae2. 8/18/2017 #4

这是我作为函数的解释：

'#######################################################################
'# LoopThroughFiles
'# Function to Loop through files in current directory and return filenames
'# Usage: LoopThroughFiles ActiveWorkbook.Path, "txt" 'inputDirectoryToScanForFile
'# https://stackoverflow.com/questions/10380312/loop-through-files-in-a-folder-using-vba
'#######################################################################
Function LoopThroughFiles(inputDirectoryToScanForFile, filenameCriteria) As String

    Dim StrFile As String
    'Debug.Print "in LoopThroughFiles. inputDirectoryToScanForFile: ", inputDirectoryToScanForFile

    StrFile = Dir(inputDirectoryToScanForFile & "\*" & filenameCriteria)
    Do While Len(StrFile) > 0
        Debug.Print StrFile
        StrFile = Dir

    Loop

End Function

42赞 Shafeek 7/24/2018

当什么都没有返回时，为什么要起作用？这与 brettdj 给出的答案不同，只是它被包含在一个函数中

6赞 felipe gaviria correa 8/29/2017 #5

Dir当我处理和处理其他文件夹中的文件时，功能很容易失去焦点。

我用这个组件得到了更好的结果。FileSystemObject

这里给出了完整的例子：

http://www.xl-central.com/list-files-fso.html

不要忘记在 Visual Basic 编辑器中设置对 Microsoft Scripting Runtime 的引用（通过使用“工具”>“引用）

试一试吧！

0赞 Marcucciboy2 7/18/2018

从技术上讲，这是提问者正在使用的方法，他们只是没有包含他们的参考资料，这会减慢这种方法的速度。

-2赞 Meelis Tara 1/11/2018 #6

试试这个。（链接)

Private Sub CommandButton3_Click()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
    xWs.Copy
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        Select Case xWb.FileFormat
            Case 51:
                FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Application.ActiveWorkbook.HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56:
                FileExtStr = ".xls": FileFormatNum = 56
            Case Else:
                FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
    End If
    xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
    Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
    Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True

End Sub

0赞 Mark A 7/29/2023 #7

这是一个返回集合的集合，然后你可以循环访问该集合 - 如果你想要的不仅仅是文件名，你可以使用字典

Sub test()
    Dim c As Collection
    Set c = LoopThroughFiles(ThisWorkbook.Path, ".xlsx")
    For Each f In c
        Debug.Print f
    Next
End Sub

Function LoopThroughFiles(inputDirectoryToScanForFile, filenameCriteria) As Collection
    Dim col As New Collection
    Dim StrFile As String
    'Debug.Print "in LoopThroughFiles. inputDirectoryToScanForFile: ", inputDirectoryToScanForFile
    StrFile = Dir(inputDirectoryToScanForFile & "\*" & filenameCriteria)
    Do While Len(StrFile) > 0
        '//Debug.Print StrFile
        col.Add StrFile
        StrFile = Dir
    Loop
    Set LoopThroughFiles = col
End Function

0赞 JohnM 7/30/2023

假设此代码的用户将使用，那么您需要声明 ie，否则代码将无法运行Option ExplicitfDim f As Variant

上一个：如何在 vba 的字符串中放置双引号？

下一个：将矩阵转换为 3 列表（'反向透视'、'取消透视'、'展平'、'归一化'）

使用VBA循环浏览文件夹中的文件？

Loop through files in a folder using VBA?

评论

评论

评论

评论

评论

评论

评论