将带有文件名的 Word 文件保存为递增数字

Question

我在互联网上找到了一个宏，它将 Word 文档中的选择保存为新文档。

Sub SaveSelectedTextToNewDocument()
    If Selection.Words.Count > 0 Then
        'Copy the selected text
        Selection.Copy

        'Open a new document and paste the copied text into it
        Dim objNewDoc As Document
        Set objNewDoc = Documents.Add
        Selection.Paste

        'Get the first 10 characters as the filename of the new document and save them
        Dim objFileName As Range
        Set objFileName = objNewDoc.Range(Start:=0, End:=10)
        objNewDoc.SaveAs FileName:="C:\Users\Test\Desktop\" & objFileName & ".docx"
    Else

    End If
End Sub

我不想将文件名的文件保存为文档的前 10 个字母。我希望文件名的数量增加（例如 1.docx、2.docx、3.docx 等）。

Answer 1

这是一个应该可以工作的宏：

Sub SaveSelectedTextToNewDocumentNumbered()
' Charles Kenyon  16 October 2021
' https://stackoverflow.com/questions/69593130/save-word-files-with-filenames-as-increasing-numbers-using-macro
'
Retry:
    If Selection.Words.Count > 0 Then
        'Copy the selected text
        Selection.Copy

        'Open a new document and paste the copied text into it
        Dim objNewDoc As Document
        Dim currentDoc As Document
        Dim sFileName As String
        Dim i As Integer
        Set currentDoc = ActiveDocument
        On Error GoTo CreateVar
        i = currentDoc.Variables("SaveNum")
        On Error GoTo -1
        i = i + 1
        Let sFileName = currentDoc.Name
        Set objNewDoc = Documents.Add
        Selection.Paste
        ' save  and assign name
        objNewDoc.SaveAs FileName:=sFileName & i
        ' update variable
        currentDoc.Variables("SaveNum") = i
        ' save original document with new variable
        currentDoc.Save
        ' cleanup
        Set currentDoc = Nothing
        Set objNewDoc = Nothing
        On Error GoTo -1
    End If
    Exit Sub
CreateVar:
    ActiveDocument.Variables("SaveNum") = 0
    GoTo Retry
End Sub