在文件夹和子文件夹中的所有文件上递归运行excel宏代码[重复]

Question

我有一个文件夹，其中有许多子文件夹，其中包含 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

Answer 2

如果我做对了，你需要一个函数来收集目录和子目录中的所有 xl 文件。这个函数会这样做：

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

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

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。这比我最初想象的要容易得多，也有点不同。我已经相应地调整了脚本。