[已解决]有选择地复制不同类型的文件 ...

松儿

有选择地复制不同类型的文件.zip (45 KB, 下载次数: 14)

2013-9-6 18:29 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-9-6 20:56

1. Dim clg As Collection
   
2. 
   
3. Sub FilesCopy()
   
4.     Dim strPathSrc As String
   
5.     Dim strPathDest As String
   
6.     Dim l As Long
   
7.     Dim strFilename As String
   
8.    
   
9.     Set clg = New Collection
   
10.     strPathSrc = ThisWorkbook.Path & Application.PathSeparator & "文件"
    
11.     strPathDest = ThisWorkbook.Path & Application.PathSeparator & "复制(模拟的结果）" & Application.PathSeparator
    
12.     Call fso(strPathSrc, "*.xls")
    
13.     For l = 1 To clg.Count
    
14.         strFilename = clg.Item(l)
    
15.         FileCopy strFilename, strPathDest & Mid(strFilename, InStrRev(strFilename, "") + 1)
    
16.     Next
    
17. End Sub
    
18. Sub fso(ByVal sPath As String, ByVal strPatterm As String)
    
19.     Dim fs As Object
    
20.     Dim fd As Object
    
21.     Dim fc As Object
    
22.     Dim s As Object, d As Object
    
23.     Set fs = CreateObject("scripting.filesystemobject")
    
24.     Set fd = fs.getfolder(sPath)
    
25.     Set fc = fd.Files
    
26.     For Each s In fc
    
27.         If UCase(s.Name) Like UCase(strPatterm) And s.Name <> ThisWorkbook.Name Then clg.Add s.Path
    
28.     Next
    
29.     For Each d In fd.SubFolders
    
30.         Call fso(d.Path, strPatterm)
    
31.     Next
    
32. End Sub

复制代码

跳转到最佳答案楼层

松儿

用VBA以文件后缀名复制文件

hwc2ycy

1. Dim clg As Collection
   
2. 
   
3. Sub FilesCopy()
   
4.     Dim strPathSrc As String
   
5.     Dim strPathDest As String
   
6.     Dim l As Long
   
7.     Dim strFilename As String
   
8.    
   
9.     Set clg = New Collection
   
10.     strPathSrc = ThisWorkbook.Path & Application.PathSeparator & "文件"
    
11.     strPathDest = ThisWorkbook.Path & Application.PathSeparator & "复制(模拟的结果）" & Application.PathSeparator
    
12.     Call fso(strPathSrc, "*.xls")
    
13.     For l = 1 To clg.Count
    
14.         strFilename = clg.Item(l)
    
15.         FileCopy strFilename, strPathDest & Mid(strFilename, InStrRev(strFilename, "") + 1)
    
16.     Next
    
17. End Sub
    
18. Sub fso(ByVal sPath As String, ByVal strPatterm As String)
    
19.     Dim fs As Object
    
20.     Dim fd As Object
    
21.     Dim fc As Object
    
22.     Dim s As Object, d As Object
    
23.     Set fs = CreateObject("scripting.filesystemobject")
    
24.     Set fd = fs.getfolder(sPath)
    
25.     Set fc = fd.Files
    
26.     For Each s In fc
    
27.         If UCase(s.Name) Like UCase(strPatterm) And s.Name <> ThisWorkbook.Name Then clg.Add s.Path
    
28.     Next
    
29.     For Each d In fd.SubFolders
    
30.         Call fso(d.Path, strPatterm)
    
31.     Next
    
32. End Sub

复制代码

松儿

hwc2ycy 发表于 2013-9-6 20:56

请增加一个复制 到自动生成的文件夹中，自动生成的文件夹名为“复制”。谢谢！

hwc2ycy

1. Sub FilesCopy()
   
2.     Dim strPathSrc As String
   
3.     Dim strPathDest As String
   
4.     Dim l As Long
   
5.     Dim strFilename As String
   
6. 
   
7.     Set clg = New Collection
   
8.     strPathSrc = ThisWorkbook.Path & Application.PathSeparator & "文件"
   
9.     strPathDest = ThisWorkbook.Path & Application.PathSeparator & "复制" & Application.PathSeparator
   
10.     On Error Resume Next
    
11.     MkDir strPathDest
    
12.     Call fso(strPathSrc, "*.xls")
    
13.     For l = 1 To clg.Count
    
14.         strFilename = clg.Item(l)
    
15.         FileCopy strFilename, strPathDest & Mid(strFilename, InStrRev(strFilename, "") + 1)
    
16.     Next
    
17. End Sub
    
18. 
    
19. Sub fso(ByVal sPath As String, ByVal strPatterm As String)
    
20.     Dim fs As Object
    
21.     Dim fd As Object
    
22.     Dim fc As Object
    
23.     Dim s As Object, d As Object
    
24.     Set fs = CreateObject("scripting.filesystemobject")
    
25.     Set fd = fs.getfolder(sPath)
    
26.     Set fc = fd.Files
    
27.     For Each s In fc
    
28.         If UCase(s.Name) Like UCase(strPatterm) And s.Name <> ThisWorkbook.Name Then clg.Add s.Path
    
29.     Next
    
30.     For Each d In fd.SubFolders
    
31.         Call fso(d.Path, strPatterm)
    
32.     Next
    
33. End Sub

复制代码

松儿

hwc2ycy 发表于 2013-9-6 21:11

没有复制到文件。

松儿

hwc2ycy 发表于 2013-9-6 21:11

生成了文件夹，但没有复制到文件。

hwc2ycy

松儿 发表于 2013-9-6 21:25
生成了文件夹，但没有复制到文件。

我这测试复制了耶。

hwc2ycy

我删除了原有的复制文件夹，再运行后，还是有文件复制成功了。

松儿

hwc2ycy 发表于 2013-9-6 21:55
我删除了原有的复制文件夹，再运行后，还是有文件复制成功了。

请给个附件。