建立文件夹，把文件归类到对应的文件夹中

Nsp=娜！再来#

请教.zip (704.07 KB, 下载次数: 44)

2018-8-29 20:35 上传

点击文件名下载附件

（图“1执行VBA前.png”）根目录下有4个文件夹，这4个文件夹里面分别有6个文件，（共有24个文件）
6个文件名称有个特点就是：
-2.mp4
-123.mp4
-2.jpg
-123.jpg
-规律.lgl
-文本.txt


请求事项：
1.根据6个文件名称的特点，分别命名建立6个文件夹；
2.做得像图“2执行VBA后.png”一样，把6个文件剪切归类到对应的文件夹中。
（1）把原来4个文件夹中有“-2.mp4”   的文件，剪切到“-2.mp4文件夹”中，
（2）把原来4个文件夹中有“-123.mp4” 的文件，剪切到“-123.mp4文件夹”中，
（3）把原来4个文件夹中有“-2.jpg”   的文件，剪切到“-2.jpg文件夹”中，
（4）把原来4个文件夹中有“-123.jpg” 的文件，剪切到“-123.jpg文件夹”中，
（5）把原来4个文件夹中有“-规律.lgl”的文件，剪切到“-规律.lgl文件夹”中，
（6）把原来4个文件夹中有“-文本.txt”的文件，剪切到“-文本.txt文件夹”中；
3.剪切全部文件后，原来的4文件夹已经是空的了，都删除掉；
4.根目录和原来的4文件夹【名字】不一定像举例这样简单，执行VBA请从根目录查找文件那24个文件。

opiona

1.     Set SHX = Worksheets("Sheet1")
   
2.     PATH原始 = ThisWorkbook.Path & "\原始文件"
   
3.     PATH结果 = ThisWorkbook.Path & "\结果"
   
4.     Set FSO = CreateObject("Scripting.FileSystemObject")
   
5.     If FSO.FolderExists(PATH结果) = True Then
   
6.         FSO.GetFolder(PATH结果).Delete   '//删除文件夹
   
7.     End If
   
8.     MkDir PATH结果    '//创建文件夹
   
9.    
   
10.     INTX = 0
    
11.     FileArr = FileAllArr(ThisWorkbook.Path, "*.*", ThisWorkbook.Name, True, False) '//含子文件夹；文件路径
    
12.     If FileArr(0) <> "" Then
    
13.         Rem 原始文件 文件清单
    
14.         For I = 0 To UBound(FileArr)
    
15.             StrNAME = GetPathFromFileName(FileArr(I), True) '//显示文件名
    
16.             For IROW = 1 To SHX.Range("A100").End(3).Row
    
17.                 Rem 找到对应文件夹名
    
18.                 If InStr(StrNAME, SHX.Cells(IROW, 1).Value) > 0 Then
    
19.                     Path = PATH结果 & "" & SHX.Cells(IROW, 1).Value
    
20.                     If FSO.FolderExists(Path) = False Then
    
21.                         MkDir Path   '//创建文件夹
    
22.                     End If
    
23.                     Rem 剪切文件过去
    
24.                     OldName = FileArr(I)
    
25.                     NewName = Path & "" & StrNAME
    
26.                     If FSO.FileExists(NewName) = True Then
    
27.                         Rem 如果重名，则前面加上序号
    
28.                         NewName = Path & "" & I & "_" & StrNAME
    
29.                     End If
    
30.                     
    
31.                     Name OldName As NewName
    
32.                     INTX = INTX + 1
    
33.                     Exit For
    
34.                 End If
    
35.             Next
    
36.             
    
37.         Next
    
38.     End If

复制代码

opiona

QQ14885553.rar (23.75 KB, 下载次数: 121)

2018-8-29 22:26 上传

点击文件名下载附件

Nsp=娜！再来#

opiona 发表于 2018-8-29 22:26

代码收到，基本能解决问题，谢谢老师！
如果能把原来4个文件夹删除，只保留新建的6个文件夹就更完美了。

opiona

结果文件夹 本来就是新建的啊！
和4个文件夹没有什么关系的！