在文件夹内的所有目录中运行excelmacrosrecursion等等

我有一个文件夹，我有很多的子文件夹，里面有超过1000个Excel文件，我想在所有1000个文件和子文件夹中运行一个特定的macros（改变wb中的东西）？ 已经为这个问题播下了答案（在VBA上），但是这个答案有两个问题，1.这个解决scheme会非常慢，有没有更快的方法？ 也许不是.. 2.这个macros只能运行在匹配的文件夹中的文件，而不是所有子文件夹中的文件，有没有办法做到这一点的子文件夹中的文件？

VBA：

Sub ProcessFiles() Dim Filename, Pathname As String Dim wb As Workbook Pathname = ActiveWorkbook.Path & "\C:\...\EXCL\" Filename = Dir(Pathname & "*.xlsx") Do While Filename <> "" Set wb = Workbooks.Open(Pathname & Filename) DoWork wb wb.Close SaveChanges:=True Filename = Dir() Loop End Sub Sub DoWork(wb As Workbook) With wb 'Do your work here ...... End With End Sub 

Answer 1

据我所知，VBA不能编辑壁橱工作簿。 如果要为每个子文件夹，子文件夹的子文件夹等中的每个工作簿执行工作，则可以使用以下代码。 我添加了条件，它必须是.xlsx文件，您可以更改它在.xls ， .xlsb或任何你想要的。

 Sub ProcessFiles() Dim objFolder As Object Dim objFile As Object Dim objFSO As Object Dim MyPath As String Dim myExtension As String Dim FldrPicker As FileDialog Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldrPicker .Title = "Select A Target Folder" .AllowMultiSelect = False If .Show <> -1 Then GoTo EmptyEnd MyPath = .SelectedItems(1) End With Application.ScreenUpdating = False Set objFSO = CreateObject("Scripting.FileSystemObject") Call GetAllFiles(MyPath, objFSO) Call GetAllFolders(MyPath, objFSO) Application.ScreenUpdating = True MsgBox "Complete." EmptyEnd: End Sub Sub GetAllFiles(ByVal strPath As String, ByRef objFSO As Object) Dim objFolder As Object Dim objFile As Object Set objFolder = objFSO.GetFolder(strPath) For Each objFile In objFolder.Files DoWork objFile.Path Next objFile End Sub Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object) Dim objFolder As Object Dim objSubFolder As Object Set objFolder = objFSO.GetFolder(strFolder) For Each objSubFolder In objFolder.subfolders Call GetAllFiles(objSubFolder.Path, objFSO) Call GetAllFolders(objSubFolder.Path, objFSO) Next objSubFolder End Sub Sub DoWork(strFile As String) Dim wb As Workbook If Right(strFile, 4) = "xlsx" Then Set wb = Workbooks.Open(Filename:=strFile) With wb 'Do your work here ...... .Close True End With End If End Sub 

Answer 2

如果我得到这个权利，你需要一个函数，收集目录和子目录中的所有xl文件。 这个function会这样做：

 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 '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 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 

这显示了如何使用它

 Sub TesterFiles() Dim colFiles As New Collection RecursiveDir colFiles, "Your Dir goes here...", "*.XLS*", True Dim vFile As Variant For Each vFile In colFiles ' Do sth with the file Debug.Print vFile Next vFile End Sub 

Answer 3

不错的一个Storax！ 我将使用Storax发布的脚本，并对其进行修改。

 i = 1 Dim vFile As Variant For Each vFile In colFiles ' Do sth with the file Range("A" & i).Value = vFile i = i + 1 Next vFile 

我认为使用列表更容易。 无论如何，一旦你有了文件结构，你可以运行刚刚创build的数组中的元素。 使用下面的脚本来做到这一点。

 Sub LoopThroughRange() Dim rng As Range, cell As Range Set rng = Range("A1:A13") For Each cell In rng 'For Fnum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(cell) On Error GoTo 0 If Not mybook Is Nothing Then 'Change cell value(s) in one worksheet in mybook On Error Resume Next With mybook.Worksheets(1) If .ProtectContents = False Then .Range("A1").Value = "My New Header" Else ErrorYes = True End If End With If Err.Number > 0 Then ErrorYes = True Err.Clear 'Close mybook without saving mybook.Close savechanges:=False Else 'Save and close mybook mybook.Close savechanges:=True End If On Error GoTo 0 Else 'Not possible to open the workbook ErrorYes = True End If 'Next Fnum Next cell End Sub 

这个想法直接来自这里。

http://www.rondebruin.nl/win/s3/win010.htm

注意这个部分：'在mybook中的一个工作表中更改单元格值这就是您希望将特定代码放在您想要执行的操作的位置。

我只是修改我的OP。 这比我最初做出来的要容易得多，有点不同。 我已经相应地调整了脚本。