Excel VBA:搜索不包括某些子目录的文件的文件夹和子目录
问题描述:
我发现了一些在线搜索目录的代码,它是满足搜索条件的文件的子目录。Excel VBA:搜索不包括某些子目录的文件的文件夹和子目录
我想修改这个代码:第一个匹配的文件中发现
- 停止等)
谁创造的目录结构中使用文件名中的空间的人,这样的文件夹的例子忽略包括“工具史”,所有子目录中的“工具史”
我发现的代码如下(抱歉,没有引用来源,我不记得在那里我发现它)
Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
' Search a folder and each of its subfolders for any files that meet the citerion given in
' strFileSpec
' colFiles - the name of the collection to add the output to
' strFolder - The path to the parent directory
' strFileSpec - The condition of the filename being searched for (for example all pdf files)
' bIncludeSubfolders - Boolean, include all subfolders in the search
' THIS FUNCTION IS SUBOPTIMAL AND VERY SLOW, PLEASE REVISIT IF USED REGULARLY
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Function TrailingSlash(strFolder As String) As String
' Search for and remove a trailing slash in the directory pathname
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
此代码是非常缓慢的,所以如果有人有任何更快,我将非常感激。
非常感谢
答
如果我是你,我会这样做。
Sub ListFilesInFolders()
Range("A:C").ClearContents
Range("A1").Value = "Folder Name"
Range("B1").Value = "File Name"
Range("C1").Value = "File Short Path"
Range("D1").Value = "File Type"
Range("A1").Select
Dim strPath As String
Dim sht As Worksheet
Dim LastRow As Long
'strPath = "C:\Data Collection\"
strPath = GetFolder
Dim OBJ As Object, Folder As Object, File As Object
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set Folder = OBJ.GetFolder(strPath)
Call ListFiles(Folder)
Dim SubFolder As Object
For Each SubFolder In Folder.SubFolders
Call ListFiles(SubFolder)
Call GetSubFolders(SubFolder)
Next SubFolder
MsgBox ("DONE!!!")
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ListFiles(ByRef Folder As Object)
If Folder Like "*History*" Then
Exit Sub
End If
Set sht = ThisWorkbook.Worksheets("Sheet1")
'Ctrl + Shift + End
r = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
With ActiveSheet
On Error Resume Next
For Each File In Folder.Files
.Cells(r, 1).Value = File.ParentFolder
.Cells(r, 2).Value = File.ShortName
.Cells(r, 3).Value = File.ShortPath
.Cells(r, 4).Value = File.Type
r = r + 1
Next File
End With
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub GetSubFolders(ByRef SubFolder As Object)
Dim FolderItem As Object
On Error Resume Next
For Each FolderItem In SubFolder.SubFolders
Call ListFiles(FolderItem)
Call GetSubFolders(FolderItem)
Next FolderItem
End Sub
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Thankyou将列出所有子目录中所有子文件夹中没有“历史记录”的文件。大!现在假设我想更新这个代码来仅列出名称为“* test.pdf”的文件,我该怎么做? – jlt199