如何根据表中某列所有单元格值在指定文件夹中搜索文件并复制到另一个文件夹

duquancai

yghgaohan 发表于 2016-11-8 11:45
大神：

    sPath1 = "X:\MG_PD\PDF图纸 和 Bom\2016\"

楼上帮你老人家改好了，自己放入模块，执行代码！你是大老爷！坐享其成啊！！！呵呵

yghgaohan

duquancai 发表于 2016-11-8 11:48
楼上帮你老人家改好了，自己放入模块，执行代码！你是大老爷！坐享其成啊！！！呵呵

多多包涵啦，我才学了一个礼拜不到。现在就是通过自己想要的实例不断学习中。。。

duquancai

yghgaohan 发表于 2016-11-8 11:53
多多包涵啦，我才学了一个礼拜不到。现在就是通过自己想要的实例不断学习中。。。

你怎么不选择 奥巴马电脑中的文件夹啊？

duquancai

1. Sub CopyFiles()
   
2. '    适合源文件夹及其子文件夹(多层文件夹)
   
3.     Dim a$(), b$(), n&, i%, j&, fso1 As Object, fol1 As Object, fol2 As Object, arr, pa1$, pa2$
   
4.     Set fol1 = CreateObject("Shell.Application").BrowseForFolder(0, "源文件夹", 0)
   
5.     If Not fol1 Is Nothing Then pa1 = fol1.Items.Item.Path Else MsgBox "源文件夹": Exit Sub
   
6.     Set fol2 = CreateObject("Shell.Application").BrowseForFolder(0, "目标文件夹", 0)
   
7.     If Not fol2 Is Nothing Then pa2 = fol2.Items.Item.Path Else MsgBox "目标文件夹": Exit Sub
   
8.     Set fso1 = CreateObject("Scripting.FileSystemObject")
   
9.     Call Fso(pa1, a, b, n)
   
10.     arr = Range("a2:a" & Range("a" & Rows.Count).End(xlUp).Row)
    
11.     For i = 1 To UBound(arr)
    
12.         For j = 1 To n
    
13.             If b(j) Like arr(i, 1) & "*" Then
    
14.                 If Not fso1.FileExists(pa2 & "" & b(j)) Then
    
15.                     fso1.CopyFile a(j), pa2 & ""
    
16.                     Exit For
    
17.                 End If
    
18.             End If
    
19.         Next
    
20.     Next
    
21.     MsgBox "复制完毕！"
    
22. End Sub
    
23. Sub Fso(myPath$, arr$(), brr$(), n&, Optional ef$ = "*.*")
    
24.     Dim fld As Object, f As Object, fd As Object
    
25.     Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    
26.     For Each f In fld.Files
    
27.         If f.Name Like ef Then
    
28.             n = n + 1
    
29.             ReDim Preserve arr(1 To n)
    
30.             ReDim Preserve brr(1 To n)
    
31.             arr(n) = f.Path: brr(n) = f.Name
    
32.         End If
    
33.     Next
    
34.     For Each fd In fld.SubFolders
    
35.         Call Fso(fd.Path, arr, brr, n, ef)
    
36.     Next
    
37. End Sub

复制代码

yghgaohan

duquancai 发表于 2016-11-8 12:16

非常感谢 ！

weiyisp

duquancai 发表于 2016-11-8 12:16

大神，你好！百度搜到咱们这个帖子后，我正好想用这个功能，复制咱们的代码、更改路径后，不管wps还是ms office 运行都提示 错误70，没有权限，调试显示  fso1.CopyFile a(j), pa2 & "" 黄色
请问是什么原因？我的是win7 sp1 32位系统 ，ms office2003  wps2019

weiyisp

duquancai 发表于 2016-11-8 12:16

好了大神，错误消失了，第15行fso1.CopyFile a(j), pa2 & ""   后边少个 & b(j)
不过现在还存在问题就是只能复制第一个带关键字的文件，其他复制不了

比如源文件夹 有名为A-1  A-2  A-3的，现在只复制了A-1


补充内容 (2018-12-25 13:24):
而且复制完毕后文件都自动增加了目标文件夹的名称

羊与臣

weiyisp 发表于 2018-12-21 10:58
好了大神，错误消失了，第15行fso1.CopyFile a(j), pa2 & ""   后边少个 & b(j)
不过现在还存在问题就 ...

请问您在使用这个代码的时候，那个excel表格的数据是当作源文件的还是就是在打开这个存有编号的excel表格里面运行代码的？

XCH1306

请问在这个程序基础上怎么添加未复制成功提醒？感谢

sjl_fyl

，留脚印学习