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

无姓人

dragonthree 发表于 2014-7-31 13:28
我在疑问改成 f2 = Dir(Mypath & "\结果\" & d1(str) & "\" & d2(str), vbDirectory)  '判断分局下面分人员 ...

我昨天也纠结了半天，后来在家中找到答案的。帖子地址：http://club.excelhome.net/thread-855099-1-1.html 的2楼，其实到现在我也没明白原因，哈哈！

无姓人

dragonthree 发表于 2014-7-31 10:20

非常感谢您一次又一次的修改，谢谢！我昨晚把您7楼的代码稍微改了一下，能得到我想要的结果！ 我在您 MkDir (Mypath & "\结果\" & d1(str) & "\" & d2(str)) 这句前加了一个判断。然后将 s = Dir改为了 s = Dir(Mypath & "\出租土地\" & "*.xls")，就这两个地方修改了。再次感谢您！

1. Sub dragonthree 老师第2次写的()
   
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.        f2 = Dir(Mypath & "\结果" & d1(str) & "" & d2(str), vbDirectory)  '判断单位下面分人员文件夹是否已经存在
    
24.        If f2 = "" Then
    
25.             MkDir (Mypath & "\结果" & d1(str) & "" & d2(str))  '新建文件夹到人员
    
26.        End If
    
27.         Set fs = CreateObject("Scripting.FileSystemObject")
    
28.         fs.movefile Mypath & "\出租土地" & s, Mypath & "\结果" & d1(str) & "" & d2(str) & ""
    
29.        's = Dir
    
30.         s = Dir(Mypath & "\出租土地" & "*.xls")
    
31.     Loop
    
32.     Set d = Nothing
    
33.     Set d1 = Nothing
    
34.     Set d2 = Nothing
    
35.     MsgBox "完成"
    
36. End Sub
    
37. 
    
38. 
    
39. 
    
40. 
    
41. 
    

复制代码

dragonthree

我在疑问改成 f2 = Dir(Mypath & "\结果\" & d1(str) & "\" & d2(str), vbDirectory)  '判断分局下面分人员文件夹是否已经存在
If f2 = "" Then
MkDir (Mypath & "\结果\" & d1(str) & "\" & d2(str))  '新建文件夹到人员
End If
s = Dir
怎么会不行呢
原来要这样的
s = Dir(Mypath & "\出租土地\" & "*.xls")

dragonthree

f2 = Dir(Mypath & "\结果\" & d1(str) & "\" & d2(str), vbDirectory)
可能就是这儿又用了一次dir吧，所以要重新写s = Dir(Mypath & "\出租土地\" & "*.xls")，这儿不能省略了吧！

无姓人

dragonthree 发表于 2014-7-31 13:36
f2 = Dir(Mypath & "\结果\" & d1(str) & "\" & d2(str), vbDirectory)
可能就是这儿又用了一次dir吧，所 ...

说的有道理，我也觉得可能是这样！

limonet

关键字：hashtable -include

limonet

Sub limonet()
    Dim i%, H$
    For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
        H = H & "';'" & Cells(i, "A") & "'='" & Cells(i, "B") & "\" & Cells(i, "C")
    Next i
    CreateObject("wscript.shell").Run "powershell push-location " & ThisWorkbook.Path _
    & "\出租土地;$h=@{" & Mid(H, 3) & "'};md ($h.values | select -unique);" _
    & "ForEach ($i in $h.Keys){Move (Dir .\* -File -Include ($i+'*')) $h[$i]}", 0
End Sub

ykcbf1100

练手，有条件建立文件夹，并把对应文件移到最终的文件夹中

ykcbf1100

练习，建立子目录，并移动文件

1. Sub ykcbf()     '//2024.6.13   文件移动
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     p = ThisWorkbook.Path & ""
   
7.     p1 = p & "出租土地"
   
8.     p2 = p & "出租土地-最终结果"
   
9.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
10.     With sh
    
11.         r = .Cells(Rows.Count, 1).End(3).Row
    
12.         arr = .[a1].Resize(r, 3)
    
13.     End With
    
14.     For i = 2 To UBound(arr)
    
15.         s = arr(i, 1)
    
16.         d(s) = arr(i, 2) & "|" & arr(i, 3)
    
17.     Next
    
18.     For Each f In fso.GetFolder(p1).Files
    
19.         fn = Replace(fso.GetBaseName(f), "出租土地", "")
    
20.         If d.exists(fn) Then
    
21.             t = Split(d(fn), "|")
    
22.             p3 = p2 & t(0) & ""
    
23.             If Not fso.FolderExists(p3) Then fso.CreateFolder p3
    
24.             p4 = p3 & t(1) & ""
    
25.             If Not fso.FolderExists(p4) Then fso.CreateFolder p4
    
26.             fso.MoveFile f, p4
    
27.         End If
    
28.     Next f
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码