求助：如何用VBA将“源文件”循环放入三级文件夹中。 谢谢！

byhyxb

求助：如何用VBA将“源文件”循环放入三级文件夹中。 谢谢！

ykcbf1100

附件供参考。。。

ykcbf1100

遍历文件夹，复制文件进去

1. Sub ykcbf()   '//2024.8.13
   
2.    
   
3.     p = ThisWorkbook.Path & ""
   
4.     With Application.FileDialog(msoFileDialogFilePicker)
   
5.         .InitialFileName = p
   
6.         .Title = "请选择要复制的文件"
   
7.         .AllowMultiSelect = False
   
8.         .Filters.Clear
   
9.         .Filters.Add "All Files", "*.*"
   
10.         If .Show Then f = .SelectedItems(1) Else Exit Sub
    
11.     End With
    
12.     getfds p, f
    
13.     MsgBox "OK！"
    
14. End Sub
    
15. 
    
16. Sub getfds(p, f)
    
17.     Set fso = CreateObject("Scripting.FileSystemObject")
    
18.     For Each fd In fso.GetFolder(p).SubFolders
    
19.         fds = fd.Path & ""
    
20.         fso.CopyFile f, fds
    
21.         getfds fd.Path, f
    
22.     Next fd
    
23. 
    
24.     Set fso = Nothing
    
25. End Sub
    

复制代码

byhyxb

Sub getfds(p, f)
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each fd In fso.GetFolder(p).SubFolders
        fds = fd.Path & "\"
        arr = Split(fds, "\")
        If InStr(arr(UBound(arr) - 1), "三") > 0 Then
            fso.CopyFile f, fds
        End If
        getfds fd.Path, f
    Next fd
    Set ff = Nothing
    Set fso = Nothing
End Sub

要求只放入第三级文件夹中，加了一个判断

byhyxb

Set ff = Nothing   应为：Set fd= Nothing  ？

ykcbf1100

byhyxb 发表于 2024-8-13 20:41
Set ff = Nothing   应为：Set fd= Nothing  ？

那句删除，没用。
把这句也删除，Dim fds As New Collection

limonet

关键字：-recurse

limonet

Sub limonet()
    CreateObject("wscript.shell").Run "powershell push-location " & ThisWorkbook.Path _
                            & ";dir -dir -recurse | %{copy 源文件.xlsx $_.fullname}", 0
End Sub

ykcbf1100

byhyxb 发表于 2024-8-13 20:12
Sub getfds(p, f)
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each fd In fso ...

如果只放入第三级文件夹，这样改一下

ykcbf1100

层级判断。。。

1. Sub ykcbf()   '//2024.8.14
   
2.     p = ThisWorkbook.Path & ""
   
3.     With Application.FileDialog(msoFileDialogFilePicker)
   
4.         .InitialFileName = p
   
5.         .Title = "请选择要复制的文件"
   
6.         .AllowMultiSelect = False
   
7.         .Filters.Clear
   
8.         .Filters.Add "All Files", "*.*"
   
9.         If .Show Then f = .SelectedItems(1) Else Exit Sub
   
10.     End With
    
11.     getfds p, 1, f
    
12.     MsgBox "OK！"
    
13. End Sub
    
14. 
    
15. Sub getfds(p, level, f)
    
16.     Set fso = CreateObject("Scripting.FileSystemObject")
    
17.     For Each fd In fso.GetFolder(p).SubFolders
    
18.         If level = 3 Then
    
19.             fso.CopyFile f, fd.Path & ""
    
20.         ElseIf level < 3 Then
    
21.             getfds fd.Path, level + 1, f
    
22.         End If
    
23.     Next fd
    
24.     Set fso = Nothing
    
25. End Sub
    

复制代码