批量修改文件名

danhanqing

有上万个文件目录，想批量修改文件名，将每个目录下的文件名前面加上流水编号，多1开始。具体要求在文件里有说明！请老师们帮忙，谢谢！
测试.rar (15.55 KB, 下载次数: 11)

2018-2-1 11:41 上传

点击文件名下载附件

6688

https://www.howtogeek.com/111859 ... ame-multiple-files/

liulang0808

增加序号，代码供参考

opiona

1. Sub A_修改文件名() '//函数实例
   
2.     Dim FileArr, WB
   
3.     Dim SHX As Worksheet
   
4.     Dim I As Long
   
5.     Dim OldName, NewName As String
   
6.    
   
7.     FileArr = FileAllArr(ThisWorkbook.Path, "*.*", ThisWorkbook.Name, True, False)
   
8.     For I = 0 To UBound(FileArr)
   
9.         OldName = FileArr(I)
   
10.         If IsNumeric(Mid(GetPathFromFileName(FileArr(I), True), 1, 7)) = False Then
    
11.             NewName = LastFoledName(FileArr(I), 0, True) & "" & Format(I + 1, "0000000") & GetPathFromFileName(FileArr(I), True)
    
12.             Name OldName As NewName
    
13.         End If
    
14.     Next
    
15.    
    
16. End Sub
    
17. 
    
18. Sub B_恢复文件名() '//函数实例
    
19.     Dim FileArr, WB
    
20.     Dim SHX As Worksheet
    
21.     Dim I As Long
    
22.     Dim OldName, NewName As String
    
23.    
    
24.     FileArr = FileAllArr(ThisWorkbook.Path, "*.*", ThisWorkbook.Name, True, False)
    
25.     For I = 0 To UBound(FileArr)
    
26.         OldName = FileArr(I)
    
27.        If IsNumeric(Mid(GetPathFromFileName(FileArr(I), True), 1, 7)) = True Then
    
28.             NewName = LastFoledName(FileArr(I), 0, True) & "" & Mid(GetPathFromFileName(FileArr(I), True), 8)
    
29.             Name OldName As NewName
    
30.         End If
    
31.     Next
    
32.    
    
33. End Sub

复制代码

opiona

测试.rar (33.93 KB, 下载次数: 20)

2018-2-1 15:03 上传

点击文件名下载附件

完整代码见附件

opiona

每个文件夹单独处理

1. Sub AA_修改文件名() '//函数实例
   
2.     Dim FileArr, DirArr
   
3.     Dim SHX As Worksheet
   
4.     Dim I As Long
   
5.     Dim OldName, NewName As String
   
6.    
   
7.     Rem 全部文件夹，含子文件夹
   
8.     DirArr = FileAllArr(ThisWorkbook.Path, "*.*", ThisWorkbook.Name, True, True)
   
9.     For X = 0 To UBound(DirArr)
   
10.         
    
11.         Rem 当前文件夹文件，不含子文件夹内文件
    
12.         FileArr = FileAllArr(DirArr(X), "*.*", ThisWorkbook.Name, False, False)
    
13.         
    
14.         For I = 0 To UBound(FileArr)
    
15.             OldName = FileArr(I)
    
16.             If Len(OldName) > 0 Then
    
17.                 If IsNumeric(Mid(GetPathFromFileName(FileArr(I), True), 1, 7)) = False Then
    
18.                     NewName = LastFoledName(FileArr(I), 0, True) & "" & Format(I + 1, "0000000") & GetPathFromFileName(FileArr(I), True)
    
19.                     Name OldName As NewName
    
20.                 End If
    
21.             End If
    
22.         Next
    
23.     Next
    
24. End Sub
    
25. 
    
26. 
    
27. Sub AB_恢复文件名() '//函数实例
    
28.    
    
29.     Dim FileArr, DirArr
    
30.     Dim SHX As Worksheet
    
31.     Dim I As Long
    
32.     Dim OldName, NewName As String
    
33.    
    
34.     Rem 全部文件夹，含子文件夹
    
35.     DirArr = FileAllArr(ThisWorkbook.Path, "*.*", ThisWorkbook.Name, True, True)
    
36.     For X = 0 To UBound(DirArr)
    
37.         
    
38.         Rem 当前文件夹文件，不含子文件夹内文件
    
39.         FileArr = FileAllArr(DirArr(X), "*.*", ThisWorkbook.Name, False, False)
    
40.         
    
41.         For I = 0 To UBound(FileArr)
    
42.             OldName = FileArr(I)
    
43.             If Len(OldName) > 0 Then
    
44.                 If IsNumeric(Mid(GetPathFromFileName(FileArr(I), True), 1, 7)) = True Then
    
45.                     NewName = LastFoledName(FileArr(I), 0, True) & "" & Mid(GetPathFromFileName(FileArr(I), True), 8)
    
46.                     Name OldName As NewName
    
47.                 End If
    
48.             End If
    
49.         Next
    
50.     Next
    
51.    
    
52. End Sub

复制代码

opiona

每个文件夹单独处理
测试.rar (36.96 KB, 下载次数: 17)

2018-2-1 15:14 上传

点击文件名下载附件

danhanqing

opiona 发表于 2018-2-1 15:14
每个文件夹单独处理

感谢老师的帮助，够细心够全面！