求助 EXECL 按列扫描文件 并复制 求高手写个

c327273381

1.指定路径（包含子目录）扫面指定列中的文件名和指定的文件类型，并把扫描到的文件路径填写到对应文件名所在行，并获取文件的最后修改信息，和扫描有无状态

2.复制扫描到的文件到指定目录

roych

已测试成功。

1. Sub ScanFile()
   
2. '引用Microsoft Scripting Runtime库
   
3. Dim fso As New FileSystemObject
   
4. Dim fl As File
   
5. Dim i As Long
   
6. Dim s As Long
   
7. Dim sPath As String, sExt As String
   
8. s = Sheets(1).Range("B7").End(xlDown).Row
   
9. sPath = Sheets(1).Range("B2")
   
10. sExt = Sheets(1).Range("D2")
    
11. For i = 7 To s
    
12.     If Len(Dir(sPath & Sheets(1).Range("B" & i) & sExt)) > 0 Then
    
13.         Sheets(1).Range("A" & i) = sPath & Sheets(1).Range("B" & i) & sExt
    
14.         Sheets(1).Range("C" & i) = "有"
    
15.         Sheets(1).Range("D" & i) = fso.getFile(sPath & Sheets(1).Range("B" & i) & sExt).DateLastModified
    
16.     Else
    
17.         Sheets(1).Range("C" & i) = "无"
    
18.     End If
    
19. Next
    
20. 
    
21. End Sub
    
22. 
    
23. Sub MoveFile()
    
24. Dim fso As New FileSystemObject
    
25. Dim i As Long
    
26. Dim s As Long
    
27. s = Sheets(1).Range("B7").End(xlDown).Row
    
28. '防止没权限创建文件夹出错
    
29. On Error Resume Next
    
30. '用len判断效率高一些。
    
31. If Len(Dir(Sheets(1).Range("B4"))) = 0 Then
    
32.     fso.CreateFolder Sheets(1).Range("B4")
    
33. End If
    
34. 
    
35. For i = 7 To s
    
36.     If Sheets(1).Range("C" & i) = "有" Then
    
37.         FileCopy Sheets(1).Range("A" & i), Sheets(1).Range("B4") & Sheets(1).Range("B" & i) & Sheets(1).Range("D2")
    
38.     End If
    
39. Next
    
40. End Sub
    

复制代码

扫描复制文件.rar (40.01 KB, 下载次数: 11)

2015-6-5 11:45 上传

点击文件名下载附件

c327273381

roych 发表于 2015-6-5 11:45
已测试成功。

试了  不过扫描不出网络共享的东西  能再改进下吗{:191:}

roych

c327273381 发表于 2015-6-5 14:00
试了  不过扫描不出网络共享的东西  能再改进下吗

楼主开玩笑吧？要不，如果不是禁用了宏，就是没有局域网的读写权限。附上我的测试截屏图：
你可以看到，提取文件前是“1月重点宝贝”文件夹的。点击提取后再切换窗口时，就生成了文件夹，而且复制了文件。

c327273381

roych 发表于 2015-6-5 14:35
楼主开玩笑吧？要不，如果不是禁用了宏，就是没有局域网的读写权限。附上我的测试截屏图：
你可以看到， ...

搞错了 {:091:} 是扫不到子目录 所以我以为扫不了  

roych

c327273381 发表于 2015-6-5 14:50
搞错了  是扫不到子目录 所以我以为扫不了

由于提取文件跟扫描文件分开操作，因此，要注意：文件不要重名，不然扫描时路径会被覆盖。
附件就不上传了。你自己在原先的附件上改改好了。
Sub ScanFile()
'引用Microsoft Scripting Runtime库
Dim fso As New FileSystemObject
Dim fl As File
Dim fd As Folder
Dim i As Long
Dim s As Long
Dim sPath As String, sExt As String
s = Sheets(1).Range("B7").End(xlDown).Row
sPath = Sheets(1).Range("B2")
sExt = Sheets(1).Range("D2")
For i = 7 To s
'子文件夹
    For Each fd In fso.GetFolder(sPath).SubFolders
        For Each fl In fd.Files
            If fl.Name = Sheets(1).Range("B" & i) & sExt Then
                Sheets(1).Range("D" & i) = fl.DateLastModified
                Sheets(1).Range("A" & i) = fl.Path
            End If
        Next
    Next
'根目录文件
    If Len(Dir(sPath & Sheets(1).Range("B" & i) & sExt)) > 0 Then
        Sheets(1).Range("A" & i) = sPath & Sheets(1).Range("B" & i) & sExt
        Sheets(1).Range("D" & i) = fso.GetFile(sPath & Sheets(1).Range("B" & i) & sExt).DateLastModified
    End If
If Len(Sheets(1).Range("A" & i)) > 0 Then
    Sheets(1).Range("C" & i) = "有"
Else
    Sheets(1).Range("C" & i) = "无"
End If

Next

End Sub