|
|
Option Explicit
Dim Fso As Object, d As Object
Sub FsoMoveFiles()
Dim sou$
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then sou = .SelectedItems(1) Else Exit Sub
End With
If Right(sou, 1) <> "\" Then sou = sou & "\"
Dim p$, des$, ar, i&, s$(1)
Set Fso = CreateObject("Scripting.FileSystemObject")
p = ThisWorkbook.Path & "\归类文件夹"
If Fso.FolderExists(p) Then Fso.DeleteFolder p '若存在，原有归类文件夹及文件删除
Fso.CreateFolder p '新建 归类文件夹
Set d = CreateObject("Scripting.Dictionary")
ar = Range("A1:B" & Cells(Rows.Count, 2).End(xlUp).Row)
For i = 1 To UBound(ar)
s(0) = ar(i, 1)
s(1) = ar(i, 2)
If Len(s(0)) And Len(s(1)) Then
des = p & "\" & s(1)
d(s(0)) = des
If Not Fso.FolderExists(des) Then Fso.CreateFolder des
End If
Next
Call FsoMove(sou)
Set Fso = Nothing
Set d = Nothing
MsgBox "ok!"
End Sub
Function FsoMove(pat$)
Dim fld, sfd, s$, f
Set fld = Fso.GetFolder(pat)
For Each f In fld.Files
s = Left(f.Name, InStrRev(f.Name, ".") - 1)
If d.Exists(s) Then Fso.MoveFile f, d(s) & "\"
Next
For Each sfd In fld.SubFolders
Call FsoMove(sfd.Path)
Next
Set fld = Nothing
End Function |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-3-18 10:02
楼主
