[已解决]查找符合要求的文件，并且复制到指定文件夹

billyzhang0609

如何将列在excel里面的模糊文件名 如：以“Small”，“Big”为关键字，
以“C:\test\"为目标文件夹，将目标文件夹中所有含有关键字的文件(包括在子文件夹中符合要求的文件)
复制到"C:\123\"下面。

请问这个如何操作？

最佳答案

月排行榜 / 总排行榜

dsmch

2015-1-4 13:05

1. Dim arr(1 To 10000, 1 To 1), s%
   
2. Sub Macro1()
   
3. Dim brr, i%, j%, zf$
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. brr = Range("a1").CurrentRegion
   
7. s = 0
   
8. zdir ThisWorkbook.Path & "\name1"
   
9. For i = 1 To s
   
10.     x = Split(arr(i, 1), "")
    
11.     zf = x(UBound(x))
    
12.     For j = 1 To UBound(brr)
    
13.         If zf Like "*" & brr(j, 1) & "*" Then
    
14.             With Workbooks.Open(Filename:=arr(i, 1))
    
15.                 '把文件复制到当前路径，楼主自己参考修改
    
16.                 .SaveAs Filename:=ThisWorkbook.Path & "" & zf
    
17.                 ActiveWorkbook.Close 1
    
18.             End With
    
19.         End If
    
20.     Next
    
21. Next
    
22. Application.DisplayAlerts = True
    
23. Application.ScreenUpdating = True
    
24. End Sub
    
25. Sub zdir(p)
    
26. Set fs = CreateObject("scripting.filesystemobject")
    
27. For Each f In fs.GetFolder(p).Files
    
28.     s = s + 1: arr(s, 1) = f
    
29. Next
    
30. For Each m In fs.GetFolder(p).SubFolders
    
31.     zdir m
    
32. Next
    
33. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Dim arr(1 To 10000, 1 To 1), s%
   
2. Sub Macro1()
   
3. Dim brr, i%, j%, zf$
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. brr = Range("a1").CurrentRegion
   
7. s = 0
   
8. zdir ThisWorkbook.Path & "\name1"
   
9. For i = 1 To s
   
10.     x = Split(arr(i, 1), "")
    
11.     zf = x(UBound(x))
    
12.     For j = 1 To UBound(brr)
    
13.         If zf Like "*" & brr(j, 1) & "*" Then
    
14.             With Workbooks.Open(Filename:=arr(i, 1))
    
15.                 '把文件复制到当前路径，楼主自己参考修改
    
16.                 .SaveAs Filename:=ThisWorkbook.Path & "" & zf
    
17.                 ActiveWorkbook.Close 1
    
18.             End With
    
19.         End If
    
20.     Next
    
21. Next
    
22. Application.DisplayAlerts = True
    
23. Application.ScreenUpdating = True
    
24. End Sub
    
25. Sub zdir(p)
    
26. Set fs = CreateObject("scripting.filesystemobject")
    
27. For Each f In fs.GetFolder(p).Files
    
28.     s = s + 1: arr(s, 1) = f
    
29. Next
    
30. For Each m In fs.GetFolder(p).SubFolders
    
31.     zdir m
    
32. Next
    
33. End Sub

复制代码

dsmch

………………

billyzhang0609

dsmch 发表于 2015-1-4 13:06
………………

我在跑程序，您的代码我等会看，谢谢啦！