问题
I have a folder where I have many sub-folders and inside of them more than 1000 Excel files.
I want to run a specific macro (that changes a workbook) on all these files.
Already saw the following answer.
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
There are two problems:
1. this will be extremely slow. Is there a faster way?
2. this will only run on the files in the matching folder and not the files in all sub-folders. Is there way to do that for files in sub-folders as well?
回答1:
As far as I know, VBA can't edit closet workbook. If you want to do work for every workbook in every subfolder, subfolder of subfolder etc. you can use the following code. I added condition, that it have to be .xlsx file, you can change it on .xls, .xlsb or whatever you want.
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
回答2:
If I get this right you need a function which collects all xl files in a directory and subdirs. This function will do that:
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
And this shows how to use it
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
回答3:
Nice one Storax! I would use the script that Storax posted, and modify it just a tad.
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
I think it's just easier to work with a list. Anyway, once you have the file structure, you can run through those elements in the array you just created. Use the script below to do that.
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
The idea comes straight from here.
http://www.rondebruin.nl/win/s3/win010.htm
Pay attention to this part: 'Change cell value(s) in one worksheet in mybook That's where you want to put specific your code to do exactly what you want to do.
I just modified my OP. It's a lot easier, and a little different, than I initially made it out to be. I've adjusted the script accordingly.
来源：https://stackoverflow.com/questions/41345805/run-excel-macro-code-recursively-on-all-files-inside-of-a-folder-and-subfolders