Save Word Files with Filenames as Increasing Numbers - vba

Question

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
I don't want to save the files with filename as the first 10 letters of the document. I want the filenames to be in increasing numbers instead (e.g. 1.docx, 2.docx, 3.docx and so on).

Answer 1

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