如何将文件夹中文件名含有相同字符的文件移入相应文件中

yzyyyyyyy

如何将文件夹中文件名含有相同字符的文件移入相应文件中.rar (12.27 KB, 下载次数: 54)

2013-8-16 12:36 上传

点击文件名下载附件

文件夹中的文件如以下格式
3-1-1-附件1
3-1-1-附件2
如何将文件移入相应的文件夹
3-1-1-附件1  移入    附件1
3-1-1-附件2  移入   附件2

wdx223

1. Sub test()
   
2. Dim fso, rw As Range, fd, f
   
3. 
   
4. Set fso = CreateObject("Scripting.FileSystemObject")
   
5. 
   
6. For Each rw In [A2:B3].Rows
   
7.     If rw.Cells(1) <> "" And rw.Cells(2) <> "" Then
   
8.         If Not fso.folderexists(ThisWorkbook.Path & "" & rw.Cells(2)) Then
   
9.              fso.getfolder(ThisWorkbook.Path).subfolders.Add rw.Cells(2)
   
10.         End If
    
11.         For Each f In fso.getfolder(ThisWorkbook.Path).Files
    
12.             If InStr(f.Name, rw.Cells(1)) > 0 Then
    
13.                 f.Move ThisWorkbook.Path & "" & rw.Cells(2) & ""
    
14.             End If
    
15.         Next f
    
16.     End If
    
17. Next rw
    
18. 
    
19. End Sub
    

复制代码

wudixin96

1. @echo off
   
2. for %%i in (*.xls) do (
   
3.   set fn=%%~ni
   
4.   call move "%%i" "%%fn:~-3%%"
   
5. )
   
6. pause

复制代码

复制这段到记事本，然后另存为BAT文件，存到XLS文件所在目录，运行即可。

wudixin96

{:soso_e100:}

yzyyyyyyy

wdx223 发表于 2013-8-16 13:01

如何将文件移入相应文件夹时，先清空文件夹中的文件

wdx223

yzyyyyyyy 发表于 2013-8-20 11:14
如何将文件移入相应文件夹时，先清空文件夹中的文件

1. Sub test()
   
2. Dim fso, rw As Range, fd, f
   
3. 
   
4. Set fso = CreateObject("Scripting.FileSystemObject")
   
5. 
   
6. For Each rw In [A2:B3].Rows
   
7.     If rw.Cells(1) <> "" And rw.Cells(2) <> "" Then
   
8.         If fso.folderexists(ThisWorkbook.Path & "" & rw.Cells(2)) Then
   
9.             fso.deletefolder (ThisWorkbook.Path & "" & rw.Cells(2))
   
10.         End If
    
11.         fso.getfolder(ThisWorkbook.Path).subfolders.Add rw.Cells(2)
    
12.         For Each f In fso.getfolder(ThisWorkbook.Path).Files
    
13.             If InStr(f.Name, rw.Cells(1)) > 0 Then
    
14.                 f.Move ThisWorkbook.Path & "" & rw.Cells(2) & ""
    
15.             End If
    
16.         Next f
    
17.     End If
    
18. Next rw
    
19. 
    
20. End Sub

复制代码

qinhuan66

好好学习天天向上

740688321

wdx223 发表于 2013-8-20 11:28

奇怪呀，这句怎么运行不了？f.Move ThisWorkbook.Path & "" & rw.Cells(2) & ""

一把小刀闯天下

740688321 发表于 2019-6-14 14:11
奇怪呀，这句怎么运行不了？f.Move ThisWorkbook.Path & "" & rw.Cells(2) & ""

目测引号中应该有一根反斜杠  "\"

740688321

一把小刀闯天下 发表于 2019-6-14 14:26
目测引号中应该有一根反斜杠  "\"

加了也不行。