Save Word Files with Filenames as Increasing Numbers using Macro-CodePudding

I am totally new to this word macro thing

I found a macro on the internet which saves the selection from a word document as a new document

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

Now the problem is I don't want it to save the files with filename as the first 10 letters of the document but I want the filenames as to be in increasing numbers instead (for e.g. 1.docx, 2.docx, 3.docx and so on....)

CodePudding user response：

Here is a macro that should work:

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