使用 VBA 遍历文件夹中的文件？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/10380312/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Loop through files in a folder using VBA?
提问by tyrex
I would like to loop through the files of a directory using vbain Excel 2010.
我想在 Excel 2010 中使用vba遍历目录的文件。
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.nametakes extremely much time.
我编写了以下代码，如果文件夹的文件不超过 50 个，则它可以正常工作，否则它会非常慢（我需要它处理具有 >10000 个文件的文件夹）。这段代码的唯一问题是查找操作file.name需要非常多的时间。
Code that works but is waaaaaay too slow (15 seconds per 100 files):
有效但太慢的代码（每 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
Problem solved:
问题解决了：
- My problem has been solved by the solution below using
Dirin a particular way (20 seconds for 15000 files) and for checking the time stamp using the commandFileDateTime. - Taking into account another answer from below the 20 seconds are reduced to less than 1 second.
- 我的问题已通过以下解决方案
Dir以特定方式解决（15000 个文件为 20 秒）并使用命令检查时间戳FileDateTime。 - 考虑到另一个答案从低于 20 秒减少到不到 1 秒。
采纳答案by benmichae2.
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
回答by brettdj
Dirtakes wild cards so you could make a big difference adding the filter for testup front and avoiding testing each file
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
回答by grantnz
Dir seems to be very fast.
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
回答by LimaNightHawk
The Dir function is the way to go, but the problem is that you cannot use the Dirfunction recursively, as stated here, towards the bottom.
Dir 函数是可行的方法，但问题是您不能Dir递归地使用该函数，如此处所述，朝向底部。
The way that I've handled this is to use the Dirfunction 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.
我处理这个问题的方法是使用该Dir函数获取目标文件夹的所有子文件夹并将它们加载到一个数组中，然后将该数组传递给一个递归函数。
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
回答by felipe gaviria correa
Dirfunction loses focus easily when I handle and process files from other folders.
Dir当我处理和处理来自其他文件夹的文件时，函数很容易失去焦点。
I've gotten better results with the component FileSystemObject.
我使用组件获得了更好的结果FileSystemObject。
Full example is given here:
这里给出了完整的例子：
http://www.xl-central.com/list-files-fso.html
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)
不要忘记在 Visual Basic 编辑器中设置对Microsoft Scripting Runtime 的引用（通过使用工具 > 引用）
Give it a try!
试一试！
回答by Meelis Tara
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) < 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
