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


236

我想使用浏览目录的文件 在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 file
End Sub

问题解决了:

  1. 我的问题已通过以下解决方案Dir以特定方式使用(对于15000个文件为20秒)并使用命令检查时间戳来解决FileDateTime
  2. 考虑到另一个答案,从20秒以下减少到不到1秒。

对于VBA来说,您的初始时间似乎很慢。您是否正在使用Application.ScreenUpdating = false?
Michiel van der Blonk

2
您似乎想念codeSet MyObj = New FileSystemObject
baldmosher

13
人们很快将FSO称为“慢速”,我感到非常可悲,但是没有人提到仅通过使用早期绑定而不是对的后期绑定就可以避免的性能损失Object
Mathieu Guindon

Answers:


46

这是我对函数的解释:

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

25
为什么起作用,什么也没有返回?与brettdj给出的答案不同,只是它包含在一个函数中
Shafeek

253

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

29
大。这只是将运行时间从20秒提高到了<1秒。这是一个很大的改进,因为代码将经常运行。谢谢!!
tyrex '04

可能是因为Do while ... loop比while ... wnd更好。这里更多信息stackoverflow.com/questions/32728334/...
HILA DG

6
我认为提高的程度(20-XXX次)不大-我认为通配符会有所作为。
brettdj '16

DIR()似乎没有返回隐藏文件。
hamish

@hamish,你可以改变它的参数,返回不同类型的文件(隐藏,系统,等等) -见MS文档:docs.microsoft.com/en-us/office/vba/language/reference/...
文森特

158

迪尔似乎很快。

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

3
很好,非常感谢。我确实使用Dir,但我不知道您也可以那样使用它。除了命令,FileDateTime我的问题也解决了。
tyrex 2012年

4
还有一个问题。如果DIR从最新文件开始循环播放,则可以大大提高速度。您看到这样做的任何方法吗?
tyrex 2012年

3
我的后一个问题已由brettdj的以下评论解决。
tyrex '04

迪尔not可是traverse the whole directory tree。如果需要的话:analyticscave.com/vba-dir-function-how-to-traverse-directories/…–
AnalystCave.com

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

26

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

如果我想列出列中找到的文件,这可能是什么实现?
jechaviz 2014年

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

6

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

使用该组件我得到了更好的结果FileSystemObject

完整示例如下:

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

不要忘记在Visual Basic编辑器中设置对Microsoft脚本运行时的引用(通过使用“工具”>“引用”)

试试看!


从技术上讲,这是请求者正在使用的方法,只是他们没有包含其引用,这会使该方法变慢。
Marcucciboy2 '18年

-2

试试这个。(链接

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
By using our site, you acknowledge that you have read and understand our Cookie Policy and Privacy Policy.
Licensed under cc by-sa 3.0 with attribution required.