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

Question

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

---

问题已解决：

1. 我通过下面的解决方案使用 Dir 方法（在 15000 个文件中花费了 20 秒）以及使用 FileDateTime 命令来检查时间戳来解决了我的问题。
2. 考虑到下面另一个答案，这 20 秒被缩短到不到 1 秒。

- tyrex

---

你的VBA初始时间似乎仍然很慢。你是否使用了Application.ScreenUpdating=false？ - Michiel van der Blonk

你似乎缺少了 code。设置 MyObj = New FileSystemObject。 - baldmosher

我觉得人们很容易就把FSO称为“慢”，但却没有人提到，如果你使用早期绑定而不是针对“Object”进行晚期绑定调用，你可以避免性能损失。 - Mathieu Guindon

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

- brettdj

---

太棒了，这将运行时间从20秒缩短到不到1秒。这是一个很大的改进，因为代码会被经常运行。谢谢！ - tyrex

我认为改进的水平（20-xxx倍）并没有起到太大作用，我认为是通配符使得区别。 - brettdj

@hamish，你可以更改它的参数以返回不同类型的文件（隐藏、系统等）-请参阅微软文档：https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dir-function - Vincent

我不理解这行代码 StrFile = Dir。它对我没用。我使用了 Output = StrFile。 - Kar.ma

对于那些看到Kar.ma的评论并且有同样疑问的人，While循环中的StrFile = Dir只是将StrFile设置为之前设置的Dir("c:\testfolder\*test*")中找到的下一个文件。例如：如果有test1.xlsx和test2.xlsx，则Debug.Print StrFile首先会给出test1，然后StrFile = Dir会找到下一个匹配项，即test2（因此仍然在while循环中）。希望这能解决一些问题。 - Notus_Panda

Answer 2

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

- grantnz

---

非常感谢。我确实使用Dir，但不知道还可以这样使用。另外，通过使用"FileDateTime"命令，我的问题得到了解决。 - tyrex

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

我的后续问题已经被brettdj在下面的评论中解决了。 - tyrex

Dir函数将不会遍历整个目录树。如有需要，请参考：http://analystcave.com/vba-dir-function-how-to-traverse-directories/#Traversing_directories - AnalystCave.com

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

所以 dir(path) 获取 path 的第一个文件，然后你必须再次调用不带参数的 dir 来获取路径的其余部分，如此所述 这里: Dir 返回与 pathname 匹配的第一个文件名。要获取任何其他文件名...。请参见这里的答案。 - Timo

Answer 3

这是我作为一个函数的解释：

'#######################################################################
'# LoopThroughFiles
'# Function to Loop through files in current directory and return filenames
'# Usage: LoopThroughFiles ActiveWorkbook.Path, "txt" 'inputDirectoryToScanForFile
'# https://dev59.com/omkv5IYBdhLWcg3wvDXq
'#######################################################################
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

- benmichae2.

---

为什么函数中没有返回值？这难道不与Brettdj的答案相同，只是封装在函数内部吗？ - Shafeek

Answer 4

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

- LimaNightHawk

---

如果我想要列出在某一列中找到的文件，有什么实现方法？ - jechaviz

@jechaviz GetFileList方法返回一个String数组。你可能只需遍历数组，并将项添加到ListView中，或者类似的操作。关于如何在ListView中显示项的详细信息可能超出了本帖的范围。 - LimaNightHawk

非常感谢，只是建议在GetFileList函数的末尾添加一个Else：If m_lNext Then ... Else ... ReDim GetFileList(0) As String。如此建议：[https://stackoverflow.com/a/35221544/6406135] - robertocm

Answer 5

Dir函数在处理来自其他文件夹的文件时很容易失去焦点。使用组件FileSystemObject可以获得更好的结果。完整示例请参见：http://www.xl-central.com/list-files-fso.html。不要忘记在Visual Basic编辑器中设置对Microsoft Scripting Runtime的引用（使用“工具”>“引用”）。试一试吧！

- felipe gaviria correa

---

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

Answer 6

这里有一个返回一个集合的例子，你可以通过迭代来使用它 - 如果你想要更多的信息而不仅仅是文件名，你可以使用字典。

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

- Mark A

---

假设使用此代码的用户会使用Option Explicit，那么您需要声明f，即Dim f As Variant，否则代码将无法运行。 - JohnM

Answer 7

试试这个。(链接)

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

- Meelis Tara