如何写代码把子文件夹的文件全部复制至一个文件夹

bet007

我现在有几十个子文件夹，里面是两个文件（不同名），但是各个子文件夹的文件名是相同的。如何写代码把子文件夹的文件全部复制至一个文件夹，并自动按序号改名。谢谢！ C.zip (58.05 KB, 下载次数: 33)

2021-1-28 17:40 上传

点击文件名下载附件

liulang0808

http://club.excelhome.net/thread-1258425-1-1.html
文件及 文件夹操作，具体需要楼主根据需求可以使用字典排序

3190496160

Sub ListFilesTest() '
Application.ScreenUpdating = False '
Set sht = ThisWorkbook.Worksheets("汇总") '
    T = Timer '
   ReDim brr(1 To 10000, 1 To 3) '
   With Application.FileDialog(msoFileDialogFolderPicker) '
    If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub '
  End With '
  If Right(myPath, 1) <> "" Then myPath = myPath & "" '
  arr = ListAllFsoDic(myPath, 1) '
  For i = 0 To UBound(arr) '
    m = Dir(arr(i) & "\*.*") '
    Do While m <> "" '
        If m <> ThisWorkbook.Name Then '
            rr = Split(m, ".")
            FileCopy arr(i) & "\" & m, "D:\合并文件\" & rr(0) & "_" & i + 1 & "." & rr(1)
        End If '
      m = Dir '
      Loop '
    Next i '
    TT = Timer - T '
    MsgBox TT '
    Application.ScreenUpdating = True '
End Sub
Function ListAllFsoDic(myPath$, Optional k = 0) '使用2个字典但无需递归的遍历过程
   Dim i&, j&
  Set d1 = CreateObject("Scripting.Dictionary") '字典d1记录子文件夹的绝对路径名
  Set d2 = CreateObject("Scripting.Dictionary") '字典d2记录文件名 （文件夹和文件分开处理）
   d1(myPath) = ""           '以当前路径myPath作为起始记录，以便开始循环检查
  Set Fso = CreateObject("Scripting.FileSystemObject")
  Do While i < d1.Count
  '当字典1文件夹中有未遍历处理的key存在时进行Do循环 直到 i=d1.Count即所有子文件夹都已处理时停止
     kr = d1.Keys '取出文件夹中所有的key即所有子文件夹路径 （注意每次都要更新）
    For Each F In Fso.GetFolder(kr(i)).Files '遍历该子文件夹中所有文件 （注意仅从新的kr(i) 开始）
         j = j + 1: d2(j) = F.Name
         '把该子文件夹内的所有文件名作为字典Item项加入字典d2 (为防止文件重名不能用key属性)
      Next
      i = i + 1 '已经处理过的子文件夹数目 i +1 （避免下次产生重复处理）
      For Each fd In Fso.GetFolder(kr(i - 1)).SubFolders '遍历该文件夹中所有新的子文件夹
          d1(fd.Path) = " " & fd.Name & ""
          '把新的子文件夹路径存入字典d1以便在下一轮循环中处理
      Next
  Loop
  If k Then ListAllFsoDic = d1.Keys Else ListAllFsoDic = d2.Items
  '如果参数=1则列出字典d1中所有子文件夹的路径名 (如使用d1.Items则仅列出子文件夹名称不含路径)
   '如果参数=0则默认列出字典d2中Items即所有文件名
End Function

3190496160

文件合并.rar (16.44 KB, 下载次数: 79)

2021-1-29 12:55 上传

点击文件名下载附件

3190496160

先在D盘新建一个文件夹，命名为   合并文件，这一步切记不能少，因为，合并后的文件就在这个文件夹内

nxxhswl

3190496160 发表于 2021-1-29 12:56
先在D盘新建一个文件夹，命名为   合并文件，这一步切记不能少，因为，合并后的文件就在这个文件夹内

这个要是能通过选择文件夹或者是新建文件夹将更灵活。

tanglf188

参与一下，顺便为自己做个小工具

ykcbf1100

练个手。批量文件复制。
复制后的文件在d:\复制后方件夹\路径下，此文件夹会自动生成。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024/4.9
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim fns As New Collection
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     p2 = "d:\复制后方件夹"
   
8.     If Not fso.FolderExists(p2) Then fso.CreateFolder p2
   
9.     p = ThisWorkbook.path & ""
   
10.     Set ff = fso.GetFolder(p)
    
11.     getFiles ff, fns, fso
    
12.     For Each f In fns
    
13.         d(f(1)) = ""
    
14.     Next
    
15.     For Each k In d.keys
    
16.         m = 0
    
17.         For Each fn In fns
    
18.             If fn(1) = k Then
    
19.                 m = m + 1
    
20.                 FileCopy fn(0), p2 & k & "-" & m & "." & fn(2)
    
21.             End If
    
22.         Next
    
23.     Next
    
24.     Set d = Nothing
    
25.     Set fso = Nothing
    
26.     Application.ScreenUpdating = True
    
27.     MsgBox "OK！"
    
28. End Sub
    
29. 
    
30. Function getFiles(ff, fns, fso)
    
31.     For Each f In ff.Files
    
32.         If f.Name Like "*.doc*" Then
    
33.             fns.Add Array(f.path, fso.GetBaseName(f), fso.GetExtensionName(f))
    
34.         End If
    
35.     Next
    
36.     For Each fd In ff.SubFolders
    
37.         getFiles fd, fns, fso
    
38.     Next
    
39. End Function
    

复制代码

wengjl

ykcbf1100 发表于 2024-4-9 16:12
参与一下。。。

你好，9楼的代码测试了一下，文件夹创建了，但复制到D盘下了。加了 “\“&  试成功了。
但看不懂语句，能不能注释一下中文的意思？谢谢！