Loop through files in a folder using VBA?

问题:

I would like to loop through the files of a directory using vba in Excel 2010.

In the loop, I will need

• the filename, and
• the date at which the file was formatted.

I have coded the following which works fine if the folder has no more then 50 files, otherwise it is ridiculously slow (I need it to work with folders with >10000 files). The sole problem of this code is that the operation to look up file.name takes extremely much time.

Code that works but is waaaaaay too slow (15 seconds per 100 files):

 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 

---

Problem solved:

1. My problem has been solved by the solution below using Dir in a particular way (20 seconds for 15000 files) and for checking the time stamp using the command FileDateTime.
2. Taking into account another answer from below the 20 seconds are reduced to less than 1 second.

回答1:

Here's my interpretation as a Function Instead:

'####################################################################### '# 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 

回答2:

Dir takes wild cards so you could make a big difference adding the filter for test up front and avoiding testing each file

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

回答3:

Dir seems to be very fast.

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:

The Dir function is the way to go, but the problem is that you cannot use the Dir function recursively, as stated here, towards the bottom.

The way that I've handled this is to use the Dir function to get all of the sub-folders for the target folder and load them into an array, then pass the array into a function that recurses.

Here's a class that I wrote that accomplishes this, it includes the ability to search for filters. (You'll have to forgive the Hungarian Notation, this was written when it was all the rage.)

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 

回答5:

Dir function loses focus easily when I handle and process files from other folders.

I've gotten better results with the component FileSystemObject.

Full example is given here:

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

Don't forget to set a reference in the Visual Basic Editor to Microsoft Scripting Runtime (by using Tools > References)

Give it a try!

回答6:

Try this one. (LINK)

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) 

文章来源: Loop through files in a folder using VBA?