在多个子文件夹中search文件的VBAmacros

我有macros，如果我把文件的单元格E1名称，macrossearch槽C：\ Users \ Marek \ Desktop \ Makro \目录find它，并将所需的值与我的原始文件的特定单元格与macros。

有没有可能使这个工作没有特定的文件夹位置？ 我需要的东西，可以search槽C：\用户\马立克\桌面\ Makro \与其中的许多子文件夹。

我的代码：

Sub Zila1() Dim SaveDriveDir As String, MyPath As String Dim FName As Variant Dim YrMth As String SaveDriveDir = CurDir MyPath = Application.DefaultFilePath 'or use "C:\Data" ChDrive MyPath ChDir MyPath FName = Sheets("Sheet1").Range("E1").Text If FName = False Then 'do nothing Else GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _ "A16:A17", Sheets("Sheet1").Range("B2:B3"), True, False GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _ "AE23:AE24", Sheets("Sheet1").Range("B3:B4"), True, False GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _ "AE26:AE27", Sheets("Sheet1").Range("B4:B5"), True, False GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _ "AQ59:AQ60", Sheets("Sheet1").Range("B5:B6"), True, False GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _ "AR65:AR66", Sheets("Sheet1").Range("B6:B7"), True, False End If ChDrive SaveDriveDir ChDir SaveDriveDir End Sub 

Answer 1

为了好玩，下面是一个带有recursion函数的示例（我希望）应该更容易理解和使用您的代码：

 Function Recurse(sPath As String) As String Dim FSO As New FileSystemObject Dim myFolder As Folder Dim mySubFolder As Folder Set myFolder = FSO.GetFolder(sPath) For Each mySubFolder In myFolder.SubFolders Call TestSub(mySubFolder.Path) Recurse = Recurse(mySubFolder.Path) Next End Function Sub TestR() Call Recurse("D:\Projets\") End Sub Sub TestSub(ByVal s As String) Debug.Print s End Sub 

编辑：这是如何在您的工作簿中实现此代码来实现您的目标。

 Sub TestSub(ByVal s As String) Dim FSO As New FileSystemObject Dim myFolder As Folder Dim myFile As File Set myFolder = FSO.GetFolder(s) For Each myFile In myFolder.Files If myFile.Name = Range("E1").Value Then Debug.Print myFile.Name 'Or do whatever you want with the file End If Next End Sub 

在这里，我只是debuggingfind的文件的名称，其余的由您决定。 ;）

当然，有人会说调用两次FileSystemObject有点笨拙，所以你可以简单地写下你的代码（取决于你想要划分还是不划分）：

 Function Recurse(sPath As String) As String Dim FSO As New FileSystemObject Dim myFolder As Folder Dim mySubFolder As Folder Dim myFile As File Set myFolder = FSO.GetFolder(sPath) For Each mySubFolder In myFolder.SubFolders For Each myFile In mySubFolder.Files If myFile.Name = Range("E1").Value Then Debug.Print myFile.Name & " in " & myFile.Path 'Or do whatever you want with the file Exit For End If Next Recurse = Recurse(mySubFolder.Path) Next End Function Sub TestR() Call Recurse("D:\Projets\") End Sub 

Answer 2

这个子将填充一个集合，其中包含所有与您传入的文件名或模式相匹配的文件。

 Sub GetFiles(StartFolder As String, Pattern As String, _ DoSubfolders As Boolean, ByRef colFiles As Collection) Dim f As String, sf As String, subF As New Collection, s If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\" f = Dir(StartFolder & Pattern) Do While Len(f) > 0 colFiles.Add StartFolder & f f = Dir() Loop sf = Dir(StartFolder, vbDirectory) Do While Len(sf) > 0 If sf <> "." And sf <> ".." Then If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then subF.Add StartFolder & sf End If End If sf = Dir() Loop For Each s In subF GetFiles CStr(s), Pattern, True, colFiles Next s End Sub 

用法：

 Dim colFiles As New Collection GetFiles "C:\Users\Marek\Desktop\Makro\", FName & ".xls", True, colFiles If colFiles.Count > 0 Then 'work with found files End If 

Answer 3

我今天刚刚发现了这个东西，我正在做的事情。 这将返回文件夹及其子文件夹中所有文件的文件path。

 RecursiveDir colFiles, "C:\Users\Marek\Desktop\Makro\", "*.*", True Dim vFile As Variant For Each vFile In colFiles 'file operation here or store file name/path in a string array for use later in the script filepath(n) = vFile filename = fso.GetFileName(vFile) 'If you want the filename without full path n=n+1 Next vFile 'These two functions are required Public Function RecursiveDir(colFiles As Collection, _strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean) Dim strTemp As String Dim colFolders As New Collection Dim vFolderName As Variant strFolder = TrailingSlash(strFolder) strTemp = Dir(strFolder & strFileSpec) Do While strTemp <> vbNullString colFiles.Add strFolder & strTemp strTemp = Dir Loop If bIncludeSubfolders Then 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 Public Function TrailingSlash(strFolder As String) As String If Len(strFolder) > 0 Then If Right(strFolder, 1) = "\" Then TrailingSlash = strFolder Else TrailingSlash = strFolder & "\" End If End If End Function 

这是从Ammara Digital Image Solutions的一篇文章中改编而来的（ http://www.ammara.com/access_image_faq/recursive_folder_search.html ）。

Answer 4

如果这有帮助，也可以使用FileSystemObject来检索文件夹的所有子文件夹。 您需要检查参考“Microsot Scripting Runtime”来获取Intellisense并使用“new”关键字。

 Sub GetSubFolders() Dim fso As New FileSystemObject Dim f As Folder, sf As Folder Set f = fso.GetFolder("D:\Proj\") For Each sf In f.SubFolders 'Code inside Next End Sub