如何修改Word VBA宏实现选中内容保存为文件名递增的Word文档

核心修改逻辑：替换原代码中取文档前10字符作为文件名的逻辑，新增遍历目标文件夹统计最大数字序号的功能，每次生成的新文件序号为当前最大序号+1，不会重复覆盖已有文件。

修改后的完整代码如下：

Sub SaveSelectedTextToNewDocument()
    If Selection.Words.Count > 0 Then
        '复制选中的内容
        Selection.Copy

        '新建空白文档并粘贴内容
        Dim objNewDoc As Document
        Set objNewDoc = Documents.Add
        Selection.Paste

        '=====递增文件名逻辑开始=====
        Dim savePath As String
        savePath = "C:\Users\Test\Desktop\" '可自行修改为目标保存路径，末尾保留反斜杠
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        Dim folder As Object
        Set folder = fso.GetFolder(savePath)
        Dim file As Object
        Dim maxNum As Integer
        maxNum = 0 '初始最大序号为0
        
        '遍历文件夹下所有docx文件，计算当前最大数字序号
        For Each file In folder.Files
            If LCase(fso.GetExtensionName(file.Name)) = "docx" Then
                Dim fileNameWithoutExt As String
                fileNameWithoutExt = fso.GetBaseName(file.Name)
                '仅识别纯数字命名的docx文件统计序号
                If IsNumeric(fileNameWithoutExt) Then
                    If CInt(fileNameWithoutExt) > maxNum Then
                        maxNum = CInt(fileNameWithoutExt)
                    End If
                End If
            End If
        Next
        
        '拼接新文件完整路径
        Dim newFileName As String
        newFileName = savePath & (maxNum + 1) & ".docx"
        '=====递增文件名逻辑结束=====

        '保存新文档并释放对象
        objNewDoc.SaveAs FileName:=newFileName
        Set fso = Nothing
        Set folder = Nothing
        Set file = Nothing
        Set objNewDoc = Nothing
    End If
End Sub

使用注意事项 #

• 如果你的桌面路径不是C:\Users\Test\Desktop\，请将代码中savePath变量的值替换为自己的目标保存路径，路径末尾必须保留反斜杠\
• 序号统计仅识别文件名是纯数字的docx文件，如果你手动在同路径下存入了5.docx，下次运行宏会自动生成6.docx，不会覆盖已有文件
• 如果运行时提示权限错误，请检查目标保存文件夹的写入权限，或更换为其他有权限的保存路径即可

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