如何创建一个 VBA 宏，将某个文件保存到特定目录中的所有子文件夹中？

Posted 2023-05-07

【中文标题】如何创建一个 VBA 宏，将某个文件保存到特定目录中的所有子文件夹中？

【英文标题】：How do i create a VB Macro that will save a certain file to all sub folders in a particular directory?

【发布时间】：2016-12-06 15:41:56

【问题描述】：

这是我目前所拥有的，可能很好，但可能不是哈哈！

我一直在尝试将一个 word 文档保存到大约 400 多个文件夹中而不必全部浏览，这可以通过 VB 宏来完成吗？我可以将其保存到目录中，但无法将其保存到所有子文件夹中。

Dim FileSystem As Object
Dim HostFolder As String
Sub DoFolder(folder)
HostFolder = ("H:\test2")

Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
    Dim SubFolder
    For Each SubFolder In folder.SubFolders
      DoFolder SubFolder
    Next
    Dim File
    For Each File In folder.Files
      Set FileSystem = CreateObject("Scripting.FileSystemObject")
      ' Operate on each file
      ActiveDocument.Save
    Next
End Sub

【问题讨论】：

您到底为什么想要同一个文件的 400 多个副本？

同一个文件发送给 400 个不同的客户，因此需要将其添加到文件夹中以进行审计记录。

【参考方案1】：

推荐阅读：Chip Pearson -Recursion And The FileSystemObject

创建一个递归子例程来遍历根目录中的所有子文件夹（及其子文件夹）。

getAllSubfolderPaths：返回一个数组，列出一个文件夹中的所有子文件夹。

Function getAllSubfolderPaths(FolderPath As String, Optional FSO As Object, Optional List As Object)
    Dim fld As Object

    If FSO Is Nothing Then
        Set FSO = CreateObject("Scripting.Filesystemobject")
        Set List = CreateObject("SYstem.Collections.ArrayList")
    End If

    List.Add FolderPath

    For Each fld In FSO.GetFolder(FolderPath).SubFolders
        getAllSubfolderPaths fld.Path, FSO, List
    Next

    getAllSubfolderPaths = List.ToArray
End Function

测试

Sub Test()
    Const RootFolder As String = "C:\Users\Owner\Pictures"
    Const SourcePath As String = "C:\Users\Owner\Documents\Youcam"
    Const SourceFileName As String = "Capture.PNG"

    Dim fld As Variant, FolderArray As Variant
    Dim Destination As String, Source As String

    FolderArray = getAllSubfolderPaths(RootFolder)

    For Each fld In FolderArray
        Destination = fld & "\" & SourceFileName
        Source = SourcePath & "\" & SourceFileName
        'Delete old copy of file
        If Destination <> Source And Len(Dir(Destination)) Then Kill Destination

        VBA.FileCopy Source:=Source, Destination:=Destination
    Next
End Sub

【讨论】：

非常感谢，当我运行你的代码时，它会毁了我的话，我做错了什么吗？？

很难说。您是否通过修改其常量来使用Sub Test()？

我做到了。每次我运行它时都会崩溃。

@Tomlawson94 将其粘贴到即时窗口中?Join(getAllSubfolderPaths("Insert Folder Path"), ",") 更正路径并按 Enter。它应该将所有文件的列表输出到即时窗口。让我知道它是否有效或使 Word 崩溃。

【参考方案2】：

一定喜欢审计要求...您基本上走在正确的道路上，但您真的只需要一个FileSystemObject。关于我看到的唯一错误是您需要此处文件夹的.Path...

For Each SubFolder In folder.SubFolders
  DoFolder SubFolder.Path   '<---Here.
Next

...而且你不需要遍历这里的所有文件（你可能有点想多了）：

For Each File In folder.Files
  Set FileSystem = CreateObject("Scripting.FileSystemObject")
  ' Operate on each file
  ActiveDocument.Save
Next

另外，我建议使用早期绑定而不是后期绑定（尽管下面的示例可以轻松切换）。我会做一些更像这样的事情：

Private Sub SaveDocToAllSubfolders(targetPath As String, doc As Document, _
                                   Optional root As Boolean = False)
    With New Scripting.FileSystemObject
        Dim current As Scripting.folder
        Set current = .GetFolder(targetPath)
        If Not root Then
            doc.SaveAs .BuildPath(targetPath, doc.Name)
        End If
        Dim subDir As Scripting.folder
        For Each subDir In current.SubFolders
            SaveDocToAllSubfolders subDir.Path, doc
        Next
    End With
End Sub

root 标志只是是否在主机文件夹中保存副本。像这样称呼它：

SaveDocToAllSubfolders "H:\test2", ActiveDocument, True

【讨论】：

非常感谢，我知道后台审核的痛苦哈哈！当我尝试使用您的代码运行它时，它实际上并没有出现我做错了什么吗？

@Tomlawson94 - 我不确定你所说的“实际上没有出现”是什么意思。它应该只在每个子文件夹中放置ActiveDocument 的副本。您是否添加了对 Microsoft Scripting Runtime 的引用？