在文件夹和子文件夹内的所有文件上递归运行excel宏代码 [英] Run excel macro code recursively on all files inside of a folder and subfolders

问题描述

我有一个文件夹，其中有很多子文件夹，并且其中有1000多个Excel文件.

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.

已经看到了以下答案.

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.这只会在匹配文件夹中的文件上运行，而不是在所有子文件夹中的文件上运行.是否也可以对子文件夹中的文件执行此操作?

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?

推荐答案

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

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

这篇关于在文件夹和子文件夹内的所有文件上递归运行excel宏代码的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！