批量修改文件夹内（文件名= 文件夹名） -excelvba

 多个同后缀仅修改一个：

Sub RenameFilesInSubfolders()
'qq443440204版权所有
On Error Resume Next
    Dim folderPath As String
    Dim subFolder As Object
    Dim file As Object
    Dim newFileName As String
    Dim fileExtension As String
    Dim fs As Object
  On Error Resume Next
    ' 设置主文件夹路径
    folderPath = "D:\xxx\" ' 请将此路径替换为你的实际路径
  If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    ' 创建FileSystemObject
    Set fs = CreateObject("Scripting.FileSystemObject")
  
    ' 获取主文件夹对象
    Set mainFolder = fs.GetFolder(folderPath)
  
    ' 遍历主文件夹下的所有子文件夹
    For Each subFolder In mainFolder.SubFolders
        ' 遍历子文件夹下的所有文件
      FolderName = Dir(subFolder, vbDirectory)
    Set folder = fs.GetFolder(subFolder)
    
    ' 遍历文件夹中的所有文件
    For Each file In folder.Files
        ' 获取文件名和扩展名
        Filename = fs.GetBaseName(file.Path)
        fileExtension = fs.GetExtensionName(file.Path)
        
        ' 重命名文件
        counter = 1
        newFileName = FolderName & "." & fileExtension
        
        ' 如果文件名已存在，则添加数字以确保唯一性
'        Do While fs.FileExists(subFolder & "\" & newFileName)
'            newFileName = FolderName & "-" & counter & "." & fileExtension
'            counter = counter + 1
'        Loop
        
        ' 执行重命名
        Name file.Path As subFolder & "\" & newFileName
    Next file
    Next subFolder
  
    ' 清理对象
    Set fs = Nothing
    Set mainFolder = Nothing
  
    MsgBox "文件重命名完成！443440204"
End Sub

全部修改版本：

Sub RenameFilesInSubfolders()
'qq443440204版权所有
on error resume next
    Dim folderPath As String
    Dim subFolder As Object
    Dim file As Object
    Dim newFileName As String
    Dim fileExtension As String
    Dim fs As Object
  On Error Resume Next
    ' 设置主文件夹路径
    folderPath = "D:\xxx\" ' 请将此路径替换为你的实际路径
  If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    ' 创建FileSystemObject
    Set fs = CreateObject("Scripting.FileSystemObject")
  
    ' 获取主文件夹对象
    Set mainFolder = fs.GetFolder(folderPath)
  
    ' 遍历主文件夹下的所有子文件夹
    For Each subFolder In mainFolder.SubFolders
        ' 遍历子文件夹下的所有文件
      FolderName = Dir(subFolder, vbDirectory)
    Set folder = fs.GetFolder(subFolder)
    
    ' 遍历文件夹中的所有文件
    For Each file In folder.Files
        ' 获取文件名和扩展名
        Filename = fs.GetBaseName(file.Path)
        fileExtension = fs.GetExtensionName(file.Path)
        
        ' 重命名文件
        counter = 1
        newFileName = FolderName & "." & fileExtension
        
        ' 如果文件名已存在，则添加数字以确保唯一性
        Do While fs.FileExists(subFolder & "\" & newFileName)
            newFileName = FolderName & "-" & counter & "." & fileExtension
            counter = counter + 1
        Loop
        
        ' 执行重命名
        Name file.Path As subFolder & "\" & newFileName
    Next file
    Next subFolder
  
    ' 清理对象
    Set fs = Nothing
    Set mainFolder = Nothing
  
    MsgBox "文件重命名完成！443440204"
End Sub