如何从子文件夹中取出并使用VBA到达主文件夹？

我有一个代码，它在子文件夹中循环从Word文档中提取数据。 但是，循环和到达子文件夹中的最后一个文档后，控制不会回到主文件夹＆然后下一个子文件夹。 请看我的代码。 帮助我，我错了。

Option Explicit Dim FSO As Scripting.FileSystemObject Dim strFolderName As String Dim wrdApp As Word.Application Dim wrdDoc As Word.Document Dim FileToOpen As String Sub FindFilesInSubFolders() Dim fsoFolder As Scripting.Folder FileToOpen = "*v2.1.doc*" If FSO Is Nothing Then Set FSO = New Scripting.FileSystemObject End If 'Set the parent folder for the new subfolders strFolderName = "C:\Test" Set fsoFolder = FSO.GetFolder(strFolderName) Set wrdApp = CreateObject("Word.Application") OpenFilesInSubFolders fsoFolder wrdApp.Quit End Sub Sub OpenFilesInSubFolders(fsoPFolder As Scripting.Folder) Dim fsoSFolder As Scripting.Folder Dim fileDoc As Scripting.File For Each fsoSFolder In fsoPFolder.SubFolders For Each fileDoc In fsoSFolder.Files If fileDoc.Name Like FileToOpen Then Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path) With wrdApp .ActiveDocument.Tables(1).Select .Selection.Copy ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)(2).PasteSpecial xlPasteValues End With wrdDoc.Close False 'wrdApp.Quit End If Next fileDoc OpenFilesInSubFolders fsoSFolder Next fsoSFolder End Sub 

Answer 1

我稍微修改了一下代码，这样它就可以在我的Office Word 2007上运行，并且运行起来非常好…以下是遍历所有文件夹的最小循环。

另请注意，您忘记在第一次调用OpenFilesInSubFolders处理文件夹的文件。

 Dim wrdApp As Object Dim FileToOpen As String Sub FindFilesInSubFolders() Dim FSO As Object Dim strFolderName As String Dim FileToOpen As String Dim fsoFolder As Object FileToOpen = "*v2.1.doc*" If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject") End If Set wrdApp = CreateObject("Word.Application") 'Set the parent folder for the new subfolders strFolderName = "C:\test" Set fsoFolder = FSO.GetFolder(strFolderName) OpenFilesInSubFolders fsoFolder End Sub Sub OpenFilesInSubFolders(fsoFolder As Object) Dim fsoSFolder As Object Dim fileDoc As Object Dim wrdDoc As Object ' ' First process the files of the curent directory, ... ' For Each fileDoc In fsoFolder.Files If fileDoc.Name Like FileToOpen Then Debug.Print fileDoc.Path Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path) With wrdApp .ActiveDocument.Tables(1).Select .Selection.Copy ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)(2).PasteSpecial xlPasteValues End With wrdDoc.Close False End If Next fileDoc ' ' ...then process all subdirectories ' For Each fsoSFolder In fsoFolder.SubFolders OpenFilesInSubFolders fsoSFolder Next fsoSFolder End Sub 

Answer 2

为什么不直接使用windows shellsearch目录，而是通过输出迭代呢？

 Sub SO() Dim files As Variant, file As Variant files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR ""C:\test\*v2.1.doc*"" /S /B /A:-D").StdOut.ReadAll,vbCrLf), ".") For Each file In files Debug.Print CStr(file) Next End Sub 

无需遍历所有的文件夹，只需一次获取文件。