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

yghgaohan

各位大神，本人小白一枚。
请教各位，如何根据表中某列所有单元格值（比如图纸号码，不带后缀）在指定文件夹中搜索文件并复制到另一个文件夹？最好VBA，采用了网上的很多代码都无法运行，本人是2007版EXCEL。
如果能实现搜索路径可用对话框选择就更好了。。。
谢谢各位大神了！！！

duquancai

这个问题最近看到多次。昨晚才解决一个。是不是很吃香？

yghgaohan

朱荣兴 发表于 2016-11-8 10:18
呵呵，上传你的excel附件来看看，才能帮到你

你好。比如 A 列是清单的“图纸号” ，除去第一行，从第二行开始往下，在文件夹： E:\工作\2016年 中搜索相对应的文件（文件类型不限，只要名称符合 A列中的值就行），然后存到 D:\工作\2016年备份\

duquancai

和这个贴几乎完全一样http://club.excelhome.net/forum. ... p;page=1#pid8874938

自己看看吧!只需要稍微改几个地方就OK！

yghgaohan

duquancai 发表于 2016-11-8 10:20
这个问题最近看到多次。昨晚才解决一个。是不是很吃香？

大神能帮我解决一下嘛，详细解释见我回复二楼，3Q5A瑞嘛吃！

duquancai

yghgaohan 发表于 2016-11-8 10:30
大神能帮我解决一下嘛，详细解释见我回复二楼，3Q5A瑞嘛吃！

自己改：对话框选取，再改几个地方就ok了，对不起，没时间给你当劳工。

yghgaohan

duquancai 发表于 2016-11-8 10:32
自己改：对话框选取，再改几个地方就ok了，对不起，没时间给你当劳工。

我来试试，非常感谢哈！

duquancai

yghgaohan 发表于 2016-11-8 10:40
我来试试，非常感谢哈！

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 & a(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 10:32
自己改：对话框选取，再改几个地方就ok了，对不起，没时间给你当劳工。

大神：

    sPath1 = "X:\MG_PD\PDF图纸 和 Bom\2016\"
    sPath2 = ThisWorkbook.Path & "\123\"
   
路径1改成如上所示（网络服务器上的一个文件夹），卡着不动了。

强制退出后显示：方法Path作用对象IFile时失败。

能看看吗？