根据单位和人员建立文件夹然后剪切文件，写的代码运行有问题，麻烦老师修正，谢谢！

无姓人

在 指定文件夹中遍历xls文件，当文件名与 清册表里的流水号 相同时，则根据单位在 指定 文件夹中建立文件夹，再在单位文件夹下建立人员文件夹，再把指定文件夹中的对应的xls文件剪切到 人员 文件夹中
我写的代码运行有问题，运行到 MyFile = Dir 这里就出错，麻烦老师帮忙修改一下，谢谢！

程序示例见： 最终结果 文件夹，我共有几万个xls文件，手工分类不敢想像，麻烦各位老师了，拜谢！！
论坛求助-建立文件夹.rar (101.51 KB, 下载次数: 14)

2014-7-30 22:01 上传

点击文件名下载附件

无姓人

麻烦哪位老师帮我看看，万分感谢！！

dragonthree

请看附件！！

dragonthree

1. 
   

复制代码

1. Sub bcfz()
   
2. Dim i&, Myr&, Arr
   
3. Dim d, d1, d2, k, str
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set d1 = CreateObject("Scripting.Dictionary")
   
6. Set d2 = CreateObject("Scripting.Dictionary")
   
7. Myr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
   
8. Arr = Sheets("Sheet1").Range("a2:c" & Myr)
   
9. For i = 1 To UBound(Arr)
   
10.     d(Arr(i, 2)) = ""
    
11.     d1(Arr(i, 1)) = Arr(i, 2)
    
12.     d2(Arr(i, 1)) = Arr(i, 3)
    
13. Next
    
14. k = d.keys
    
15. MkDir (ThisWorkbook.Path & "\结果")    '新建文件夹
    
16. For i = 0 To d.Count - 1
    
17.     MkDir (ThisWorkbook.Path & "\结果" & "" & k(i))   '新建二级文件夹
    
18. Next
    
19. s = Dir(ThisWorkbook.Path & "\出租土地" & "*.xls")
    
20. Do While s <> ""
    
21.      str = Left(s, 15)
    
22.      MkDir (ThisWorkbook.Path & "\结果" & d1(str) & "" & d2(str))
    
23.      Set fs = CreateObject("Scripting.FileSystemObject")
    
24.      fs.movefile ThisWorkbook.Path & "\出租土地" & s, ThisWorkbook.Path & "\结果" & d1(str) & "" & d2(str) & ""
    
25.      s = Dir
    
26. Loop
    
27. Set d = Nothing
    
28. Set d1 = Nothing
    
29. Set d2 = Nothing
    
30. End Sub
    

复制代码

dragonthree

新建了一个"结果"文件夹！

无姓人

dragonthree 发表于 2014-7-30 23:13
请看附件！！

万分感谢dragonthree老师在百忙之中帮助我，谢谢谢谢！！我先学习下您的代码，有问题再向您请教！！

dragonthree

1. Sub bcfz()
   
2. Dim i&, Myr&, Arr
   
3. Dim d, d1, d2, k, str, Mypath
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set d1 = CreateObject("Scripting.Dictionary")
   
6. Set d2 = CreateObject("Scripting.Dictionary")
   
7. Myr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
   
8. Arr = Sheets("Sheet1").Range("a2:c" & Myr)
   
9. Mypath = ThisWorkbook.Path
   
10. For i = 1 To UBound(Arr)
    
11.     d(Arr(i, 2)) = ""
    
12.     d1(Arr(i, 1)) = Arr(i, 2)
    
13.     d2(Arr(i, 1)) = Arr(i, 3)
    
14. Next
    
15. k = d.keys
    
16. MkDir (Mypath & "\结果")     '新建文件夹
    
17. For i = 0 To d.Count - 1
    
18.     MkDir (Mypath & "\结果" & "" & k(i))    '新建二级文件夹
    
19. Next
    
20. s = Dir(Mypath & "\出租土地" & "*.xls")
    
21. Do While s <> ""
    
22.      str = Left(s, 15)
    
23.      MkDir (Mypath & "\结果" & d1(str) & "" & d2(str))
    
24.      Set fs = CreateObject("Scripting.FileSystemObject")
    
25.      fs.movefile Mypath & "\出租土地" & s, Mypath & "\结果" & d1(str) & "" & d2(str) & ""
    
26.      s = Dir
    
27. Loop
    
28. Set d = Nothing
    
29. Set d1 = Nothing
    
30. Set d2 = Nothing
    
31. End Sub
    

复制代码

无姓人

dragonthree 发表于 2014-7-30 23:48
有没有一个人员对应2个流水号？

有的，一个人员有可能会对应多 个流水号的情况。这么晚了还麻烦您，辛苦了！谢谢！！

dragonthree

有没有一个人员对应2个流水号？

dragonthree

1. Sub bcfz()
   
2. Dim i&, Myr&, Arr
   
3. Dim d, d1, d2, d3, k, str, Mypath
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set d1 = CreateObject("Scripting.Dictionary")
   
6. Set d2 = CreateObject("Scripting.Dictionary")
   
7. Set d3 = CreateObject("Scripting.Dictionary")
   
8. Myr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
   
9. Arr = Sheets("Sheet1").Range("a2:c" & Myr)
   
10. Mypath = ThisWorkbook.Path
    
11. For i = 1 To UBound(Arr)
    
12.     d(Arr(i, 2)) = ""
    
13.     d1(Arr(i, 1)) = Arr(i, 2)
    
14.     d2(Arr(i, 1)) = Arr(i, 3)
    
15. Next
    
16. k = d.keys
    
17. MkDir (Mypath & "\结果")     '新建文件夹
    
18. For i = 0 To d.Count - 1
    
19.     MkDir (Mypath & "\结果" & "" & k(i))    '新建二级文件夹
    
20. Next
    
21. s = Dir(Mypath & "\出租土地" & "*.xls")
    
22. Do While s <> ""
    
23.      str = Left(s, 15)
    
24.      If Not d3.exists(d1(str) & "" & d2(str)) Then
    
25.          d3(d1(str) & "" & d2(str)) = ""
    
26.          MkDir (Mypath & "\结果" & d1(str) & "" & d2(str))
    
27.      End If
    
28.      Set fs = CreateObject("Scripting.FileSystemObject")
    
29.      fs.movefile Mypath & "\出租土地" & s, Mypath & "\结果" & d1(str) & "" & d2(str) & ""
    
30.      s = Dir
    
31. Loop
    
32. Set d = Nothing
    
33. Set d1 = Nothing
    
34. Set d2 = Nothing
    
35. Set d3 = Nothing
    
36. End Sub
    

复制代码