循环通过文件夹中的文件使用VBA?

我想在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解决了(20秒用于15000个文件)，并使用命令FileDateTime检查时间戳。
  2. 考虑到另一个答案从20秒以下减少到1秒以下。
746361 次浏览
小开

迪尔似乎很快。

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
小开

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
小开

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
小开
最佳答案

以下是我对函数的解释:

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

Dir函数在处理和处理其他文件夹中的文件时容易失去焦点。

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

完整的例子如下:

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

不要忘记在Visual Basic编辑器中将引用设置为微软脚本运行时(通过使用工具>引用)

试试吧!

小开

试试这个。(链接)

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

提交答案