基于Excel表格批量重命名多层级文件夹文件的VBA求助

针对你需要按Excel映射表批量重命名多层文件夹内文件的需求，先指出你提供代码的核心问题，再给出适配场景的完整VBA模块：

原代码的核心问题 #

• 使用FileCopy仅复制文件，未执行重命名操作（需用Name命令）
• 未定义DestPath变量，运行时会触发编译错误
• 通配符*可能匹配多个相似文件名，导致误操作
• 固定循环100行，无法适配实际数据行数
• 未遍历子文件夹，无法处理顶层文件夹下的多层文件

适配多层文件夹的VBA模块 #

Sub BatchRenameFilesFromExcel()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim topFolderPath As String
    Dim originalFileName As String, newFileName As String
    Dim fso As Object, folder As Object, subFolder As Object
    
    ' 设置参数：修改为你的顶层文件夹路径，结尾需带\
    topFolderPath = "C:\YourTopFolderPath\"
    ' 设置当前工作表（假设映射表在当前激活的工作表）
    Set ws = ActiveSheet
    ' 初始化文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 获取A列最后一行数据
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历Excel映射表
    For i = 1 To lastRow
        originalFileName = Trim(ws.Cells(i, "A").Value)
        newFileName = Trim(ws.Cells(i, "B").Value)
        
        ' 跳过空行
        If originalFileName = "" Or newFileName = "" Then GoTo NextRow
        
        ' 遍历顶层文件夹及所有子文件夹
        Set folder = fso.GetFolder(topFolderPath)
        SearchAndRename folder, originalFileName, newFileName
        
NextRow:
    Next i
    
    MsgBox "批量重命名操作完成！", vbInformation
    Set fso = Nothing
    Set folder = Nothing
End Sub

' 递归搜索文件夹并重命名文件的子过程
Sub SearchAndRename(currentFolder As Object, originalName As String, newName As String)
    Dim file As Object
    Dim subFolder As Object
    
    ' 遍历当前文件夹内的文件
    For Each file In currentFolder.Files
        ' 精确匹配文件名（含后缀）
        If file.Name = originalName Then
            On Error Resume Next
            ' 执行重命名，捕获错误（如文件已存在、权限不足）
            Name file.Path As currentFolder.Path & "\" & newName
            If Err.Number <> 0 Then
                MsgBox "重命名失败：" & originalName & vbCrLf & "错误原因：" & Err.Description, vbExclamation
                Err.Clear
            End If
            On Error GoTo 0
            Exit For ' 找到匹配文件后退出当前文件夹循环
        End If
    Next file
    
    ' 递归遍历子文件夹
    For Each subFolder In currentFolder.SubFolders
        SearchAndRename subFolder, originalName, newName
    Next subFolder
End Sub

使用说明 #

1. 确保Excel表格的A列为完整原文件名（包含后缀，如Q1_Report.pdf），B列为完整新文件名（包含后缀）
2. 修改代码中topFolderPath为你的目标顶层文件夹路径，路径结尾必须加上反斜杠\
3. 打开Excel表格，按Alt+F11打开VBA编辑器，插入新模块后粘贴上述代码
4. 运行BatchRenameFilesFromExcel宏即可开始批量重命名

额外提示 #

• 建议先在测试文件夹中验证代码，避免误操作
• 若需要模糊匹配文件名（如仅匹配文件名部分内容），可将If file.Name = originalName Then修改为If InStr(file.Name, originalName) > 0 Then，但需注意可能匹配多个文件的风险

内容的提问来源于stack exchange，提问作者Katie Bird