使用VBA宏提取Word文档以“Expediente N°”开头的最后一行实现批量重命名

原代码问题说明 #

• 正向查找逻辑会匹配文档中第一个出现的Expediente N°，无法定位到最后一行的目标内容
• 仅选中查找关键词本身，没有提取后续的动态数字编号
• 缺失批量遍历文档、重命名文件的完整逻辑

修改后完整可运行代码 #

Sub 批量按Expediente编号重命名Word()
    Dim fso As Object
    Dim folderPath As String
    Dim docFile As Object
    Dim wordApp As Word.Application
    Dim targetDoc As Word.Document
    Dim findRange As Range
    Dim expedienteNum As String
    Dim newFileName As String
    Dim duplicateCount As Integer
    
    ' 选择待处理的文档文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems(1) & "\"
    End With
    
    ' 初始化文件系统对象和Word应用对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set wordApp = New Word.Application
    wordApp.Visible = False ' 后台运行不显示窗口
    duplicateCount = 1
    
    ' 遍历文件夹下所有Word文档
    For Each docFile In fso.GetFolder(folderPath).Files
        If LCase(fso.GetExtensionName(docFile.Name)) Like "doc*" Then
            ' 跳过打开中的临时文件
            If Left(docFile.Name, 2) <> "~$" Then
                On Error Resume Next
                Set targetDoc = wordApp.Documents.Open(docFile.Path, ReadOnly:=True)
                On Error GoTo 0
                
                If Not targetDoc Is Nothing Then
                    ' 从文档末尾倒序查找目标内容
                    Set findRange = targetDoc.Content
                    findRange.Collapse Direction:=wdCollapseEnd
                    
                    With findRange.Find
                        .Text = "Expediente N° "
                        .Forward = False ' 倒序查找
                        .Wrap = wdFindStop ' 找到文档开头就停止
                        .MatchCase = False
                        If .Execute Then
                            ' 扩展选中到行尾，提取编号
                            findRange.Expand Unit:=wdLine
                            expedienteNum = Trim(Replace(findRange.Text, "Expediente N° ", ""))
                            ' 去掉换行符等特殊字符
                            expedienteNum = Replace(Replace(expedienteNum, Chr(13), ""), Chr(11), "")
                            
                            ' 拼接新文件名，处理重名
                            newFileName = folderPath & "Expediente_" & expedienteNum & "." & fso.GetExtensionName(docFile.Name)
                            Do While fso.FileExists(newFileName)
                                newFileName = folderPath & "Expediente_" & expedienteNum & "_" & duplicateCount & "." & fso.GetExtensionName(docFile.Name)
                                duplicateCount = duplicateCount + 1
                            Loop
                            duplicateCount = 1
                            
                            ' 关闭文档后重命名
                            targetDoc.Close SaveChanges:=wdDoNotSaveChanges
                            Name docFile.Path As newFileName
                        Else
                            ' 没找到目标内容直接关闭文档
                            targetDoc.Close SaveChanges:=wdDoNotSaveChanges
                        End If
                    End With
                    Set targetDoc = Nothing
                End If
            End If
        End If
    Next
    
    ' 释放资源
    wordApp.Quit
    Set wordApp = Nothing
    Set fso = Nothing
    MsgBox "批量重命名完成！"
End Sub

运行注意事项 #

• 运行前请先备份所有待处理文档，避免误操作导致文件丢失
• 需要先在VBA编辑器的「工具-引用」中勾选「Microsoft Word xx.x Object Library」
• 若文档中存在多个Expediente N°标识，代码会自动匹配最后一处（即最后一行的目标内容）
• 自动处理重名文件，重名时会自动追加序号避免覆盖

内容的提问来源于stack exchange，提问作者Diego Pacheco