[已解决]批量移动工作薄到相应文件夹的问题

dfshm

附件 批量移动工作薄到相应文件夹附件.rar (351.93 KB, 下载次数: 11)

2016-4-19 20:12 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2016-4-20 10:46

1. Dim sht
   
2. Sub Macro1()
   
3. On Error Resume Next
   
4. sht = ThisWorkbook.FullName
   
5. aa ThisWorkbook.Path & ""
   
6. End Sub
   
7. Sub aa(p)
   
8. Set fs = CreateObject("scripting.filesystemobject")
   
9. For Each f In fs.GetFolder(p).Files
   
10.     If sht <> f Then
    
11.         x = Split(f, "")
    
12.         y = Replace(f, ".xlsx", "")
    
13.         f2 = y & "\A" & x(UBound(x))
    
14.         fs.MoveFile f, f2
    
15.     End If
    
16. Next
    
17. For Each m In fs.GetFolder(p).SubFolders
    
18.     aa m
    
19. Next
    
20. End Sub

复制代码

跳转到最佳答案楼层

dsmch

貌似回答了这个问题
http://www.excelpx.com/thread-387113-1-1.html

dfshm

dsmch 发表于 2016-4-19 22:23
貌似回答了这个问题
http://www.excelpx.com/thread-387113-1-1.html

老师您好，随着数据的增多，原来那个已不适应了。现在这个，增加了一层路径。

dsmch

1. Dim sht
   
2. Sub Macro1()
   
3. On Error Resume Next
   
4. sht = ThisWorkbook.FullName
   
5. aa ThisWorkbook.Path & ""
   
6. End Sub
   
7. Sub aa(p)
   
8. Set fs = CreateObject("scripting.filesystemobject")
   
9. For Each f In fs.GetFolder(p).Files
   
10.     If sht <> f Then
    
11.         x = Split(f, "")
    
12.         y = Replace(f, ".xlsx", "")
    
13.         f2 = y & "\A" & x(UBound(x))
    
14.         fs.MoveFile f, f2
    
15.     End If
    
16. Next
    
17. For Each m In fs.GetFolder(p).SubFolders
    
18.     aa m
    
19. Next
    
20. End Sub

复制代码