excel - 在文件夹和子文件夹内的所有文件上递归运行 excel 宏代码

Question

这个问题在这里已经有了答案:





Get list of sub-directories in VBA

(5 个回答)


2年前关闭。




我有一个文件夹，其中有许多子文件夹，其中包含 1000 多个 Excel 文件。

我想在所有这些文件上运行一个特定的宏(更改工作簿)。

已经看到下面的答案了。

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

有两个问题:
1. 这会非常慢。有更快的方法吗？
2. 这只会在匹配文件夹中的文件上运行，而不是在所有子文件夹中的文件上运行。有没有办法对子文件夹中的文件执行此操作？

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