Dictionary+Folder+File+FileSystemObject胡应用。

ning84

1. Function CheckFolder(Fso As Scripting.FileSystemObject, Sht As Worksheet) As Folder
   
2.     'Dim oFolder As Folder, oFile As File
   
3.     Dim Yyyy, YyyyMm, PathName
   
4.         With Sht
   
5.              Yyyy = Split(.Name, "年")(0) & "年"
   
6.              YyyyMm = Split(.Name, "月")(0) & "月"
   
7.         End With
   
8.         PathName = ThisWorkbook.Path & "" & Yyyy
   
9.         
   
10.         If Not Fso.FolderExists(PathName) Then
    
11.              Fso.CreateFolder PathName
    
12.         End If
    
13.         '''
    
14.         PathName = ThisWorkbook.Path & "" & Yyyy & "" & YyyyMm
    
15.         If Not Fso.FolderExists(PathName) Then
    
16.              Fso.CreateFolder PathName
    
17.         End If
    
18.         PathName = ThisWorkbook.Path & "" & Yyyy & "" & YyyyMm & "" & Sht.Name
    
19.         If Not Fso.FolderExists(PathName) Then
    
20.              Fso.CreateFolder PathName
    
21.         End If
    
22.         Set CheckFolder = Fso.GetFolder(PathName)
    
23. 
    
24. End Function
    
25. 
    
26. Private Sub ShtNameToFolder()
    
27.     Dim Fso As Scripting.FileSystemObject
    
28.         Set Fso = New Scripting.FileSystemObject
    
29.     Dim oDate As Date, Str, Arr
    
30.     Dim CurrentFolder As Folder, AimFolder As Folder
    
31.     Dim oFile As File, oFile1 As File
    
32.     Dim Sht As Worksheet, Rng As Range, oRow
    
33.         Set Sht = Application.ActiveSheet
    
34.         Set AimFolder = CheckFolder(Fso, Sht)
    
35.         Set CurrentFolder = Fso.GetFolder(ThisWorkbook.Path)
    
36.         'Debug.Print AimFolder.Path, CurrentFolder.Path
    
37.     Dim PathName
    
38.         PathName = ThisWorkbook.Path
    
39.     Dim FileDict As Scripting.Dictionary
    
40.         Set FileDict = New Scripting.Dictionary
    
41.         With Sht
    
42.             oRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
43.             
    
44.             For ii = 4 To oRow
    
45.                
    
46.                   
    
47.                    If Fso.FolderExists(CurrentFolder.Path) Then
    
48.                        PathName = CurrentFolder.Path & "" & .Cells(ii, 1)
    
49.                        If Fso.FileExists(PathName) Then
    
50.                           Set oFile1 = Fso.GetFile(PathName)
    
51.                        End If
    
52.                        PathName = CurrentFolder.Path & "" & .Cells(ii, 2)
    
53.                        If Fso.FileExists(PathName) Then
    
54.                           Set oFile = Fso.GetFile(PathName)
    
55.                        End If
    
56.                        
    
57.                        If Not oFile Is Nothing Then
    
58.                            Set FileDict(oFile) = oFile1
    
59.                        End If
    
60.                    End If
    
61.             Next ii
    
62.         End With
    
63.         ''
    
64.         With FileDict
    
65.             For ii = 0 To .Count - 1
    
66.                  Debug.Print .Keys(ii).Path, .Items(ii).Path
    
67.                  Fso.MoveFile .Keys(ii), AimFolder
    
68.                  Fso.MoveFile .Items(ii), AimFolder
    
69.             Next ii
    
70.         End With
    
71. End Sub
    

复制代码