VBA关于文件夹的复制，遍历，查询等综合案列求助

itmwdtn

我需要将每个订单的所涉及的型号，在[技术文件]这个文件夹中找出，并复制到
指定路径，中的新建文件夹以该表的订单号为文件名。这是第1步
   并且我只需要其中的含有标签的文件，其余文件要删掉



详见附件：

liulang0808

http://club.excelhome.net/thread-1258425-1-1.html
文件夹相关资料可以参考

itmwdtn

万能的论坛啊~~~我坐等大神~~

itmwdtn

自己顶一下~~~~~有没有大侠出手相助一下~~

小花鹿

主要就是个遍历文件的问题                                                                                         

itmwdtn

小花鹿 发表于 2018-8-1 09:05
主要就是个遍历文件的问题                                                                             ...

我自己认为，只取出含有标签的文件，也是一个难点

itmwdtn

再顶一下~跪求大神~~~出手相助~~

itmwdtn

自己顶下，有需要的朋友也一起顶下

xiangbaoan

仅测试参考，也是帮你顶一下。

1. Sub test()
   
2. Dim ar, p$, sp$, np$, fld, sfd, f, r%, fso As Object
   
3. Set fso = CreateObject("scripting.filesystemobject")
   
4. p = ThisWorkbook.Path & ""
   
5. ar = Sheet1.[a1].CurrentRegion.Resize(, 4)
   
6. On Error Resume Next
   
7. For r = 2 To UBound(ar)
   
8.     np = p & ar(r, 2)
   
9.     If Dir(np, vbDirectory) = "" Then fso.createfolder np
   
10.     np = np & ""
    
11.     sp = p & "技术文件" & ar(r, 1) & ""
    
12.     For Each fld In fso.getfolder(sp).subfolders
    
13.         If fld.Name = ar(r, 3) Then
    
14.             fso.movefolder sp & fld.Name, np & fld.Name
    
15.         End If
    
16.     Next
    
17. Next
    
18. Err.Clear
    
19. For Each fld In fso.getfolder(p).subfolders
    
20.     If fld.Name <> "技术文件" Then
    
21.         For Each sfd In fld.subfolders
    
22.             For Each f In sfd.Files
    
23.                 If InStr(f.Name, "标签") = 0 Then Kill f
    
24.             Next
    
25.         Next
    
26.     End If
    
27. Next
    
28. Set fso = Nothing
    
29. End Sub

复制代码

itmwdtn

xiangbaoan 发表于 2018-8-7 10:16
仅测试参考，也是帮你顶一下。

太强大了，我再仔细研究一下