[已解决]批量移动工作薄的问题

dfshm

附件 移动工作薄到相应文件夹.rar (152.08 KB, 下载次数: 15)

2016-3-28 22:02 上传

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

最佳答案

月排行榜 / 总排行榜

dsmch

2016-3-28 22:50

1. Sub Macro1()
   
2. mypath = ThisWorkbook.Path & ""
   
3. wj = Dir(mypath & "*.xls*")
   
4. Set fs = CreateObject("scripting.filesystemobject")
   
5. Do While wj <> ""
   
6.     If wj <> ThisWorkbook.Name Then
   
7.         f1 = mypath & wj
   
8.         n = Mid(Split(wj, ".xls")(0), 2)
   
9.         f2 = mypath & n & "" & wj
   
10.         fs.MoveFile f1, f2
    
11.     End If
    
12. wj = Dir
    
13. Loop
    
14. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. mypath = ThisWorkbook.Path & ""
   
3. wj = Dir(mypath & "*.xls*")
   
4. Set fs = CreateObject("scripting.filesystemobject")
   
5. Do While wj <> ""
   
6.     If wj <> ThisWorkbook.Name Then
   
7.         f1 = mypath & wj
   
8.         n = Mid(Split(wj, ".xls")(0), 2)
   
9.         f2 = mypath & n & "" & wj
   
10.         fs.MoveFile f1, f2
    
11.     End If
    
12. wj = Dir
    
13. Loop
    
14. End Sub

复制代码

dfshm

dsmch 发表于 2016-3-28 22:50

老师你好，麻烦看看下面这个附件，跟一楼的一模一样．却不能操作．怪事了．一样的文件夹，一样的工作薄，一楼的附件．一楼的放入代码后，能操作．下面的附件，放入代码后，却不能操作．

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

2016-3-29 23:18 上传

点击文件名下载附件

dsmch

1. Sub Macro1()
   
2. mypath = ThisWorkbook.Path & ""
   
3. wj = Dir(mypath & "*.xls*")
   
4. Set fs = CreateObject("scripting.filesystemobject")
   
5. Do While wj <> ""
   
6.     If wj <> ThisWorkbook.Name Then
   
7.         f1 = mypath & wj
   
8.         n = Mid(Split(wj, ".xls")(0), 2)
   
9.         '文件夹名如果不存在则自动增加
   
10.         If Not fs.FolderExists(mypath & n) Then fs.CreateFolder (mypath & n)
    
11.         f2 = mypath & n & "" & wj
    
12.         fs.MoveFile f1, f2
    
13.     End If
    
14. wj = Dir
    
15. Loop
    
16. End Sub

复制代码