请教高手如何批量修改各个文件夹下的文件名，文件名改为其所在的文件夹名

seezzz

请教老师，工作中遇到了一个问题，有上百个文件夹，每个文件夹下面都有一个名为新建 Microsoft Excel 工作表.xlsx的文件，如求助附件所示，想要得到的效果是文件夹1里的excel文件改名为文件夹1.xlsx，文件夹2里的excel文件改名为文件夹2.xlsx，依此类推，批量修改上百个文件夹内的文件名。搜了半天论坛实在没找解决办法，只好来求助各位老师了，谢谢！

chxw68

1. Sub test()
   
2.   Dim fso As Object
   
3.   Dim f1 As Variant
   
4.   Dim f2 As Variant
   
5.   Dim myname$
   
6.   Application.DisplayAlerts = False
   
7.   Set fso = CreateObject("Scripting.FileSystemObject")
   
8.   For Each f1 In fso.GetFolder(ThisWorkbook.Path).SubFolders
   
9.     For Each f2 In fso.GetFolder(f1.Path).Files
   
10.       myname = f1.Name & "." & Split(f2.Name, ".")(1)
    
11.       If Dir(f1.Path & "" & myname) = "" Then
    
12.         f2.Name = f1.Name & "." & Split(f2.Name, ".")(1)
    
13.       End If
    
14.     Next
    
15.   Next
    
16. End Sub
    

复制代码

chxw68

详见附件。

seezzz

chxw68 发表于 2017-3-8 16:56
详见附件。

问题得到解决，太感谢您了！

cbtaja

用递归方法，可以搜索处理多层目录： 改名.rar (13.1 KB, 下载次数: 466)

2017-3-8 17:17 上传

点击文件名下载附件

1. Sub renameas()
   
2. Dim fl As Object, obj As Object, mypath$
   
3. mypath = ThisWorkbook.Path
   
4. Set obj = CreateObject("scripting.filesystemobject")
   
5. Set fl = obj.Getfolder(mypath)
   
6. rena fl
   
7. End Sub
   
8. 
   
9. Function rena(fld As Object)
   
10. Dim subfl As Object
    
11.     For Each f In fld.Files
    
12.         If f.Name Like "*.xlsx" Then
    
13.             f.Name = fld.Name & ".xlsx"
    
14.             Exit For
    
15.         End If
    
16.     Next
    
17.     For Each subfl In fld.subfolders
    
18.         rena subfl
    
19.     Next
    
20. End Function

复制代码

lxl46

chxw68 发表于 2017-3-8 16:55

大侠，帮帮小弟吧，看看我这个问题该如何解决啊，万分感谢
http://club.excelhome.net/thread-1375169-1-1.html

Pan嗯嗯

chxw68 发表于 2017-3-8 16:55

1. Sub test()
   
2.   Dim fso As Object
   
3.   Dim f1 As Variant
   
4.   Dim f2 As Variant
   
5.   Dim myname As String
   
6.   Application.DisplayAlerts = False     '禁止显示提示和警告消息
   
7.   Set fso = CreateObject("Scripting.FileSystemObject")
   
8.   For Each f1 In fso.GetFolder(ThisWorkbook.Path).SubFolders        '遍历该工作薄路径下的所有文件夹
   
9.     For Each f2 In fso.GetFolder(f1.Path).Files '遍历该文件夹下所有文件
   
10.       myname = f1.Name & "." & Split(f2.Name, ".")(1)       '提取文件夹名和该文件的后缀名，作为新文件名称
    
11.       If Dir(f1.Path & "" & myname) = "" Then      '如果不存在同名的文件
    
12.         f2.Name = myname        '修改文件名称
    
13.       End If
    
14.     Next
    
15.   Next
    
16.   Application.DisplayAlerts = True  '恢复显示提示和警告消息
    
17. End Sub
    
18. 
    

复制代码

谢谢chxw68老师的代码，学习了！！！

LMY123

文件名称加上文件夹名称

1. Sub test()
   
2.   Dim fso As Object
   
3.   Dim f1 As Variant
   
4.   Dim f2 As Variant
   
5.   Dim myname$
   
6.   Application.DisplayAlerts = False
   
7.   Set fso = CreateObject("Scripting.FileSystemObject")
   
8.   For Each f1 In fso.GetFolder(ThisWorkbook.Path).SubFolders
   
9.     For Each f2 In fso.GetFolder(f1.Path).Files
   
10.       myname = f1.Name & "." & Split(f2.Name, ".")(1)
    
11.       If Dir(f1.Path & "" & myname) = "" Then
    
12.         f2.Name = f1.Name & "-" & Split(f2.Name, ".")(0) & "." & Split(f2.Name, ".")(1)
    
13.       End If
    
14.     Next
    
15.   Next
    
16. End Sub

复制代码

Sub renameas()
Dim fl As Object, obj As Object, mypath$
mypath = ThisWorkbook.Path
Set obj = CreateObject("scripting.filesystemobject")
Set fl = obj.Getfolder(mypath)
rena fl
End Sub

Function rena(fld As Object)
Dim subfl As Object
    For Each f In fld.Files
        If f.Name Like "*.xlsx" Then
            f.Name = fld.Name & "-" & f.Name
            Exit For
        End If
    Next
    For Each subfl In fld.subfolders
        rena subfl
    Next
End Function

zhouxing2008

cbtaja 发表于 2017-3-8 17:18
用递归方法，可以搜索处理多层目录：

方法很好,很适用,可是如果一个文件夹下有多个文件,怎么同时对多个文件重命名啊

xj123321

学习了